Skip to content

Commit

Permalink
Change to Req instead of HTTP Client
Browse files Browse the repository at this point in the history 
Squashed commit of the following:

commit ca6c6cd
Author: pingu <nor@acorneroftheweb.com>
Date:   Wed May 29 20:59:48 2024 +0200

    Real fulhack goes brrr

commit eb329f1
Merge: e9fb0c0 040b4ec
Author: Nor Führ <49118502+The1Penguin@users.noreply.github.com>
Date:   Wed May 29 20:30:43 2024 +0200

    Merge branch 'main' into 93-time-out-resilience

commit e9fb0c0
Author: pingu <nor@acorneroftheweb.com>
Date:   Wed May 29 19:38:25 2024 +0200

    New docker image build only with tags

commit 5764f10
Author: pingu <nor@acorneroftheweb.com>
Date:   Wed May 29 19:21:23 2024 +0200

    Hadolint & Jassob suggestions

commit 1057cf0
Author: pingu <nor@acorneroftheweb.com>
Date:   Wed May 29 19:10:31 2024 +0200

    Damn you Cral

commit e2ee0a4
Author: pingu <nor@acorneroftheweb.com>
Date:   Wed May 29 18:34:40 2024 +0200

    New build

commit 9b6b0e6
Author: Jacob Jonsson <jacob.t.jonsson@gmail.com>
Date:   Wed Oct 11 21:15:42 2023 +0200

    chore: update README.md with new instructions

    We're no longer using `stack` to build and we're missing instructions
    for NixOS/Nix package manager.

commit b02e794
Author: Emily Tiberg <emily.jo.tiberg@gmail.com>
Date:   Thu May 23 10:00:04 2024 +0200

    Fixar länk till kårrestaurangens veckomeny

commit a080f45
Author: pingu <nor@acorneroftheweb.com>
Date:   Mon Sep 25 16:35:32 2023 +0200

    Added a flake build instead of shell.nix

    Added for ability to compile

    update to newer lts while we are at it

    I am very tired

commit 5aae4c7
Author: Andreas Ekeroot <andeke@gmail.com>
Date:   Sun Sep 24 19:39:20 2023 +0200

    Get time-out-resilience by using `req` HTTP client

    Replace `http-client` with `req` and use all the sweet retry
    functionality from `req`. `req` uses a Fibonacci sequence to back off.
    This also lets us remove loads of code.

    Close #93.
  • Loading branch information
@The1Penguin
The1Penguin committed May 29, 2024
1 parent 040b4ec commit 85dadfc
Show file tree
Hide file tree
Showing 7 changed files with 62 additions and 140 deletions.
9 changes: 3 additions & 6 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,6 @@ import Data.Time.Format ( defaultTimeLocale
import Lens.Micro.Platform ( set
, view
)
import Network.HTTP.Client.TLS ( newTlsManager )
import Network.Wai.Middleware.RequestLogger ( logStdout )
import Network.Wai.Middleware.StaticEmbedded ( static )
import System.Console.GetOpt ( ArgDescr(..)
Expand All @@ -49,7 +48,6 @@ import Web.Scotty ( get

import Config
import Model
import Model.Types ( ClientContext(..) )
import View ( render )

opts :: [OptDescr (Config -> Config)]
Expand All @@ -72,7 +70,6 @@ main = (reifyConfig . getOpt Permute opts <$> getArgs) >>= \case
(Config { _cHelp = True }, _ , _ ) -> usage
(config , _ , _ ) -> do
upd <- newEmptyMVar -- putMVar when to update
mgr <- newTlsManager
viewRef <- createViewReference

-- In the list there are three items running concurrently:
Expand All @@ -83,17 +80,17 @@ main = (reifyConfig . getOpt Permute opts <$> getArgs) >>= \case
Async.Concurrently
[ timer upd config
, webserver config viewRef upd
, updater mgr upd viewRef config
, updater upd viewRef config
]
where
timer upd cfg =
forever $ tryPutMVar upd () >> threadDelay (view cInterval cfg)

updater mgr upd viewRef cfg =
updater upd viewRef cfg =
forever
$ withFDHandler defaultBatchingOptions stdout 1.0 80
$ \logCallback -> runLoggingT
(runReaderT (refresh viewRef upd) (ClientContext cfg mgr))
(runReaderT (refresh viewRef upd) cfg)
( logCallback
. renderWithTimestamp
(formatTime defaultTimeLocale "T%H:%M:%S")
Expand Down
9 changes: 6 additions & 3 deletions mat-chalmers.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,14 +38,14 @@ library
, css-text >= 0.1.3.0 && < 0.2
, exceptions >= 0.10.5 && < 0.11.0
, heredoc == 0.2.0.0
, http-client >= 0.7.13.1 && < 0.8
, http-client-tls >= 0.3.6.1 && <= 0.4
, logging-effect >= 1.4.0 && <= 2.0
, microlens-platform >= 0.4.3.3 && < 0.5
, lucid >= 2 && < 3
, mtl == 2.2.2
, old-locale == 1.0.0.7
, prettyprinter == 1.7.1
, req >= 3.13 && < 4.0
, retry == 0.8.1.2
, safe == 0.3.19
, tagsoup == 0.14.8
, text >= 2.0 && <= 3.0
Expand All @@ -60,11 +60,13 @@ executable mat-chalmers
build-depends: mat-chalmers
, base
, bytestring
, exceptions
, file-embed
, http-client-tls >= 0.3.5.3
, microlens-platform
, logging-effect
, mtl
, req
, prettyprinter
, scotty >= 0.12.1 && < 0.13
, time >= 1.12 && < 1.13
, wai-extra >= 3.1.13.0 && < 4.0
Expand All @@ -80,6 +82,7 @@ Test-Suite test-mat
build-depends: base
, bytestring
, mat-chalmers
, aeson >= 2.1.2.1 && < 3.0
, hspec >= 2.10.10 && < 3.0
, HUnit >= 1.6.2.0 && < 2.0
, text
Expand Down
33 changes: 20 additions & 13 deletions src/Model.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, NumericUnderscores, OverloadedStrings #-}
module Model
( Restaurant(..)
, Menu(..)
Expand All @@ -23,12 +23,17 @@ import Control.Monad.Log ( MonadLog
import Control.Monad.Reader ( MonadReader
, asks
)
import Control.Retry ( fibonacciBackoff
, limitRetries
)
import Data.IORef ( IORef
, newIORef
, writeIORef
)
import Data.Foldable ( for_ )
import Data.Text.Lazy ( pack )
import Data.Text.Lazy ( fromStrict
, pack
)
import Prettyprinter ( Doc
, pretty
)
Expand All @@ -45,12 +50,12 @@ import Lens.Micro.Platform ( (^.)
, (%~)
, view
)
import Network.HTTP.Req

import Config
import Model.Types
import Model.Karen
import Model.Wijkanders
import Util

-- | Refreshes menus.
-- The refresh function evaluates to `Some monad m => m (View model, Update signal)`,
Expand All @@ -60,7 +65,7 @@ refresh
:: ( Monad m
, MonadIO m
, MonadLog (WithTimestamp (Doc ann)) m
, MonadReader ClientContext m
, MonadReader Config m
, MonadThrow m
)
=> IORef View -> MVar () -> m ()
Expand All @@ -78,29 +83,31 @@ createViewReference = liftIO $ do
update
:: ( MonadIO m
, MonadLog (WithTimestamp (Doc ann)) m
, MonadReader ClientContext m
, MonadReader Config m
, MonadThrow m
)
=> m View
update = do
c <- asks ccCfg
dateNow <- liftIO $ fmap (view _zonedTimeToLocalTime) getZonedTime
nextDayHour <- asks _cNextDayHour
dateNow <- liftIO $ fmap (view _zonedTimeToLocalTime) getZonedTime
let (textday, d) =
if (dateNow ^. (_localTimeOfDay . _todHour)) >= view cNextDayHour c
if dateNow ^. _localTimeOfDay . _todHour >= nextDayHour
then
("Tomorrow", dateNow & (_localDay . gregorian . _ymdDay) %~ (+ 1))
else ("Today", dateNow)
let day' = d ^. _localDay
let karenR = fetchAndCreateRestaurant day'
rest <- sequence
rest <- runReq (
defaultHttpConfig {
httpConfigRetryPolicy = fibonacciBackoff 30_000_000 <> limitRetries 5
}) $ sequence
[ karenR "K\229rrestaurangen"
"karrestaurangen"
"21f31565-5c2b-4b47-d2a1-08d558129279"
, karenR "S.M.A.K." "smak" "3ac68e11-bcee-425e-d2a8-08d558129279"
, karenR "L's Kitchen" "ls-kitchen" "c74da2cf-aa1a-4d3a-9ba6-08d5569587a1"
, fmap
(Restaurant "Wijkanders" (pack wijkandersAPIURL) . (>>= getWijkanders day'))
(safeGetBS wijkandersAPIURL)
, Restaurant "Wijkanders" (fromStrict $ renderUrl wijkandersAPIURL) .
getWijkanders day' . responseBody <$> req GET wijkandersAPIURL NoReqBody lbsResponse mempty
]

for_ rest $ \r -> case menu r of
Expand All @@ -110,4 +117,4 @@ update = do

return (View rest textday d)
where
wijkandersAPIURL = "http://www.wijkanders.se/restaurangen/"
wijkandersAPIURL = http "www.wijkanders.se" /: "restaurangen"
70 changes: 29 additions & 41 deletions src/Model/Karen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,14 +10,11 @@ where
import Control.Monad ( (>=>) )
import Control.Monad.Catch ( MonadThrow )
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.Reader ( MonadReader )
import Data.Aeson ( object
, (.=)
, encode
, (.:)
, withArray
, withObject
, eitherDecode
, Value
)
import Data.Aeson.Types ( Parser
Expand All @@ -26,33 +23,24 @@ import Data.Aeson.Types ( Parser
import Data.Bifunctor ( first )
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Foldable ( find )
import Data.Functor ( (<&>) )
import Data.Text.Lazy ( Text
, unpack
)
import Data.Thyme.Calendar ( Day
, showGregorian
)
import Network.HTTP.Client ( RequestBody(..)
, method
, parseRequest
, requestBody
, requestHeaders
)
import Network.HTTP.Req
import Text.Heredoc ( str )

import Model.Types ( ClientContext(..)
, NoMenu(..)
import Model.Types ( NoMenu(..)
, Menu(..)
, Restaurant
( Restaurant
)
)
import Util ( menusToEitherNoLunch
, safeBS
)
import Util ( menusToEitherNoLunch )

apiURL :: String
apiURL = "https://plateimpact-heimdall.azurewebsites.net/graphql"

-- brittany-disable-next-binding
graphQLQuery :: String
Expand Down Expand Up @@ -82,18 +70,19 @@ type Language = String

-- | Fetch a menu from Kårens GraphQL API.
fetch
:: (MonadIO m, MonadReader ClientContext m, MonadThrow m)
=> String -- ^ RestaurantUUID
-> Day -- ^ Day
-> m (Either NoMenu BL8.ByteString) -- ^ Either a bytestring payload or a NoMenu error
fetch restaurantUUID day = do
initialRequest <- parseRequest apiURL
safeBS
(initialRequest { method = "POST"
, requestBody = RequestBodyLBS $ encode requestData
, requestHeaders = [("Content-Type", "application/json")]
}
)
:: (MonadHttp m, MonadIO m, MonadThrow m)
=> String -- ^ RestaurantUUID
-> Day -- ^ Day
-> m Value -- ^ A JSON response or horrible crash
fetch restaurantUUID day =
req
POST
(https "plateimpact-heimdall.azurewebsites.net" /: "graphql")
(ReqBodyJson requestData)
jsonResponse
mempty
<&> responseBody

where
requestData = object
[ "query" .= graphQLQuery
Expand All @@ -108,18 +97,17 @@ fetch restaurantUUID day = do
-- | Parses menus from Kåren's GraphQL API.
parse
:: Language -- ^ Language
-> BL8.ByteString -- ^ Bytestring payload from fetch
-> Either NoMenu [Menu] -- ^ Either list of parsed Menu's or NoMenu error
-> Value -- ^ JSON result from `fetch`
-> Either NoMenu [Menu] -- ^ Either list of parsed `Menu`s or `NoMenu` error
parse lang =
failWithNoMenu eitherDecode
>=> failWithNoMenu
(parseEither
( withObject "Parse meals"
$ (.: "data")
>=> (.: "dishOccurrencesByTimeRange")
>=> mapM menuParser
)
)
failWithNoMenu
(parseEither
( withObject "Parse meals"
$ (.: "data")
>=> (.: "dishOccurrencesByTimeRange")
>=> mapM menuParser
)
)
>=> menusToEitherNoLunch
where
failWithNoMenu :: Show a => (a -> Either String b) -> a -> Either NoMenu b
Expand All @@ -145,7 +133,7 @@ parse lang =

-- | Fetch a restaurant from Kåren's GraphQL API
fetchAndCreateRestaurant
:: (MonadIO m, MonadReader ClientContext m, MonadThrow m)
:: (MonadHttp m, MonadIO m, MonadThrow m)
=> Day -- ^ Day
-> Text -- ^ Title
-> Text -- ^ Tag
Expand All @@ -159,4 +147,4 @@ fetchAndCreateRestaurant day title tag uuid =
<> "/"
<> uuid
)
<$> fmap (parse "Swedish" =<<) (fetch (unpack uuid) day)
<$> fmap (parse "Swedish") (fetch (unpack uuid) day)
12 changes: 0 additions & 12 deletions src/Model/Types.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}

-- | Types and internal functions

Expand All @@ -7,16 +6,6 @@ module Model.Types where
import Data.ByteString.Lazy ( ByteString )
import Data.Text.Lazy ( Text )
import Data.Thyme ( LocalTime )
import Network.HTTP.Client ( HttpException
, Manager
)

import Config ( Config )

data ClientContext = ClientContext
{ ccCfg :: Config
, ccManager :: Manager
}

-- | What to pass to template.
data View = View
Expand All @@ -34,7 +23,6 @@ data Restaurant = Restaurant

data NoMenu
= NoLunch
| NMHttp HttpException
| NMParseError String ByteString -- ^ The parse error. The string we tried to parse.
deriving (Show)

Expand Down
Loading

0 comments on commit 85dadfc

Please sign in to comment.