-
Notifications
You must be signed in to change notification settings - Fork 9
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Linsen, you have arrived #126
Changes from 7 commits
02128e7
f25bd67
a3c9089
d9d1f6d
f99f05e
f4818cc
30700ea
6bfd82e
5b4e3c7
b6fa09e
92d28ab
8feb0a9
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,101 @@ | ||
{-# LANGUAGE FlexibleContexts, OverloadedStrings, LambdaCase #-} | ||
|
||
module Model.Linsen | ||
( | ||
parse | ||
, fetchAndCreateLinsen | ||
) | ||
where | ||
|
||
import Control.Monad ( (>=>) | ||
, (<=<) | ||
, zipWithM | ||
, ap | ||
) | ||
import Control.Monad.Catch ( MonadThrow ) | ||
import Control.Monad.IO.Class ( MonadIO ) | ||
import Data.Aeson ( (.:) | ||
, withObject | ||
, Value | ||
) | ||
import Data.Aeson.Types ( Parser | ||
, parseEither | ||
) | ||
import Data.Bifunctor ( first ) | ||
import qualified Data.ByteString.Lazy.Char8 as BL8 | ||
import Data.Functor ( (<&>) ) | ||
import Data.Text.Lazy ( Text | ||
, replace | ||
, strip ) | ||
import Data.Thyme.Calendar ( Day ) | ||
import Network.HTTP.Req | ||
import Model.Types ( NoMenu(..) | ||
, Menu(..) | ||
, Restaurant | ||
( Restaurant | ||
) | ||
) | ||
import Util ( menusToEitherNoLunch ) | ||
import Data.Thyme.Calendar.WeekDate ( toWeekDate ) | ||
|
||
fetch | ||
:: (MonadHttp m, MonadIO m, MonadThrow m) | ||
=> m Value -- ^ A JSON response or horrible crash | ||
fetch = | ||
req | ||
GET | ||
(https "cafe-linsen.se" /: "api" /: "menu") | ||
NoReqBody | ||
jsonResponse | ||
mempty | ||
<&> responseBody | ||
|
||
parse | ||
:: Day -- ^ Day to parse | ||
-> Value -- ^ JSON result from `fetch` | ||
-> Either NoMenu [Menu] -- ^ Either list of parsed `Menu`s or `NoMenu` error | ||
parse day = | ||
failWithNoMenu | ||
(parseEither | ||
( withObject "Parse meals" | ||
$ (.: "docs") | ||
>=> (pure . (!! (6 - (\(_,_,a) -> a) (toWeekDate day)))) | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Indices and arithmetic makes parsing so much better. Do we get the whole week in the json blob and then pick the correct day by index? There's a way to get the third element from something by using the lens There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. The whole week is in the blob. I changed a bit of the code here, but haven't figured out how to index into the list with lenses without also introducing |
||
>=> (.: "richText") | ||
>=> (.: "root") | ||
>=> (.: "children") | ||
>=> menuParser | ||
) | ||
) | ||
>=> menusToEitherNoLunch | ||
where | ||
failWithNoMenu :: Show a => (a -> Either String b) -> a -> Either NoMenu b | ||
failWithNoMenu action x = | ||
first (\msg -> NMParseError msg . BL8.pack . show $ x) (action x) | ||
|
||
menuParser :: [Value] -> Parser [Menu] | ||
menuParser = pure . (zip [0 :: Integer ..] >=> \case | ||
(2 ,vs) -> [vs] | ||
(6 ,vs) -> [vs] | ||
(10,vs) -> [vs] | ||
_ -> []) <=< ap (zipWithM sumFood) tail | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I think I need more context to understand this code. What do 2, 6 and 10 mean? Otherwise this code feels very much in line with the spirit of this code base. Good job! |
||
|
||
sumFood :: Value -> Value -> Parser Menu | ||
sumFood a b = Menu <$> getFood a <*> getFood b | ||
|
||
getFood :: Value -> Parser Text | ||
getFood = withObject "Menu Object" | ||
$ (.: "children") | ||
>=> \case | ||
[] -> pure mempty | ||
vs -> last vs .: "text" | ||
<&> strip . replace "/ " ", " | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Nitpick: This code is quite an experience to read since it goes both left to right and right to left. If you pick one direction it becomes less eye-jumpy. Something like: There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. That makes sense, changed that in the last commit added |
||
|
||
fetchAndCreateLinsen | ||
:: (MonadHttp m, MonadIO m, MonadThrow m) | ||
=> Day -- ^ Day | ||
-> m Restaurant -- ^ Fetched Restaurant | ||
fetchAndCreateLinsen day = | ||
Restaurant | ||
"Café Linsen" | ||
"https://plateimpact-screen.azurewebsites.net/menu/week/" | ||
<$> fmap (parse day) fetch |
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -5,6 +5,7 @@ import Data.Aeson ( decode ) | |
import Data.Maybe ( fromJust ) | ||
import Data.Thyme.Time.Core ( fromGregorian ) | ||
import Model.Karen ( parse ) | ||
import qualified Model.Linsen as L ( parse ) | ||
import Model.Types ( Menu(..) | ||
, NoMenu | ||
) | ||
|
@@ -48,6 +49,25 @@ main = hspec $ do | |
) | ||
) | ||
|
||
describe "Cafe Linsen" $ it | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Tests <3 |
||
"parses a blob of JSON without error" | ||
(do | ||
s1 <- BL.readFile "test/linsen.json" | ||
testFun | ||
[ Menu | ||
(T.pack "Natt Överbakad Högrev.") | ||
(T.pack "Rotfrukter, Timjansky, Persilja, Pommes Chateau.") | ||
, Menu | ||
(T.pack "Stekt Fisk.") | ||
(T.pack "Remouladsås, Citron, Dill, Picklade Morötter, Rostad Potatis.") | ||
, Menu | ||
(T.pack "Chana Masala.") | ||
(T.pack "Kikärtor, Grönsaker, Potatis Pakora, Nannbröd, Ris") | ||
] (L.parse | ||
(fromGregorian 2024 05 31) | ||
(fromJust $ decode s1)) | ||
) | ||
|
||
describe "The Wijkander's" | ||
$ it "Parses two blobs of HTML correctly on fridays" | ||
$ do | ||
|
Large diffs are not rendered by default.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
<&>
<- pretty!