From f8bfff05386a08ca42bba93256c94ba7a02e1249 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Thu, 25 Aug 2022 21:47:40 +0200 Subject: [PATCH] Refactor Aeson instances --- src/Lisa/Squeak.hs | 99 ++++++++++++++++++++++++---------------------- 1 file changed, 51 insertions(+), 48 deletions(-) diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs index a3592fa..069d203 100644 --- a/src/Lisa/Squeak.hs +++ b/src/Lisa/Squeak.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImpredicativeTypes #-} @@ -6,11 +7,14 @@ module Lisa.Squeak where import Control.Applicative ((<|>)) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value, (.:), (.:?), (.=), object, withObject) +import Data.Aeson (FromJSON(parseJSON), FromJSONKey(fromJSONKey), Options(fieldLabelModifier), ToJSON(toJSON), Value, (.:), (.:?), (.=), defaultOptions, genericParseJSON, genericToJSON, object, withObject) import Data.Text (Text) import Data.Time.Calendar (Day) +import GHC.Generics (Generic) import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Req, Scheme, Url, defaultHttpConfig, http, https, port, jsonResponse, responseBody, req, runReq) +import qualified Data.Char as Char + -- | Dependency Inversion for monads that can run requests. -- By requiring 'HasEndpointInfo' and 'MonadIO' for functions that perform requests we don't need to import anything from Scotty. class HasEndpointInfo m where @@ -49,25 +53,23 @@ joinErrors (Left errors) = Left $ GQLErrors errors joinErrors (Right (SqueakErrorOr inner)) = inner -- ^ A GraphQL query with a bunch of variables. -data GQLQuery v = GQLQuery Text v - deriving (Show) +data GQLQuery v = GQLQuery + { gqlQueryQuery :: Text + , gqlQueryVariables :: v + } + deriving (Generic, Show) instance ToJSON v => ToJSON (GQLQuery v) where - toJSON (GQLQuery query variables) = object - [ "query" .= query - , "variables" .= variables - ] + toJSON = genericToJSON $ removePrefixOpts "gqlQuery" data GQLReply a = GQLReply { gqlReplyData :: Maybe a , gqlReplyErrors :: Maybe [GQLError] } - deriving (Show) + deriving (Generic, Show) instance FromJSON a => FromJSON (GQLReply a) where - parseJSON = withObject "GQLReply" $ \v -> GQLReply - <$> v .: "data" - <*> v .:? "errors" + parseJSON = genericParseJSON $ removePrefixOpts "gqlReply" replyToEither :: GQLReply a -> Either [GQLError] a replyToEither (GQLReply (Just data') _) = Right data' @@ -77,19 +79,38 @@ replyToEither _ = error "Invalid GQLReply: Neither 'dat data GQLError = GQLError { gqlErrorMessage :: Text } - deriving (Show) + deriving (Generic, Show) instance FromJSON GQLError where - parseJSON = withObject "GQLError" $ \v -> GQLError - <$> v .: "message" + parseJSON = genericParseJSON $ removePrefixOpts "gqlError" +-- TODO: doc data Documents = Documents { unDocuments :: [Document] } deriving (Show) +-- TODO: doc instance FromJSON Documents where parseJSON = withObject "Documents" $ \v -> Documents <$> ((v .: "documents") >>= (.: "results")) +-- | Helper for automatically writing 'FromJSON' instances. +-- +-- >>> removePrefixModifier "document" "documentId" +-- "id" +-- >>> removePrefixModifier "document" "documentPublicComment" +-- "publicComment" +removePrefixModifier :: String -> String -> String +removePrefixModifier prefix = lowercaseFirst . stripPrefix prefix + where + stripPrefix [] word = word + stripPrefix (p:ps) (c:cs) + | p == c = stripPrefix ps cs + | otherwise = error $ "Invalid prefix " ++ ps ++ " (" ++ prefix ++ ") for key " ++ cs + stripPrefix _ [] = error $ "Prefix " ++ prefix ++ " is too long" + lowercaseFirst (c:cs) = Char.toLower c : cs + +removePrefixOpts prefix = defaultOptions { fieldLabelModifier = removePrefixModifier prefix } + data Document = Document { documentId :: Text , documentDate :: Day @@ -99,48 +120,35 @@ data Document = Document , documentLectures :: [Lecture] , documentDownloadable :: Bool } - deriving (Show) + deriving (Show, Generic) instance FromJSON Document where - parseJSON = withObject "Document" $ \v -> Document - <$> v .: "id" - <*> v .: "date" - <*> v .: "semester" - <*> v .: "publicComment" - <*> v .: "faculty" - <*> v .: "lectures" - <*> v .: "downloadable" + parseJSON = genericParseJSON $ removePrefixOpts "document" data Faculty = Faculty { facultyId :: Text , facultyDisplayName :: Text } - deriving (Show) + deriving (Generic, Show) instance FromJSON Faculty where - parseJSON = withObject "Faculty" $ \v -> Faculty - <$> v .: "id" - <*> v .: "displayName" + parseJSON = genericParseJSON $ removePrefixOpts "faculty" data Lectures = Lectures { unLectures :: [Lecture] } - deriving (Show) + deriving (Generic, Show) instance FromJSON Lectures where - parseJSON = withObject "Lectures" $ \v -> Lectures - <$> v .: "lectures" + parseJSON = genericParseJSON $ removePrefixOpts "un" data Lecture = Lecture { lectureId :: Text , lectureDisplayName :: Text , lectureAliases :: [Text] } - deriving (Show) + deriving (Generic, Show) instance FromJSON Lecture where - parseJSON = withObject "Lecture" $ \v -> Lecture - <$> v .: "id" - <*> v .: "displayName" - <*> v .: "aliases" + parseJSON = genericParseJSON $ removePrefixOpts "lecture" getAllLectures :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Lecture]) getAllLectures = fmap unLectures <$> joinErrors <$> mkQuery @@ -168,22 +176,18 @@ instance FromJSON LoginResult where data Credentials = Credentials { credentialsToken :: Text , credentialsUser :: User - } deriving (Show) + } deriving (Generic, Show) instance FromJSON Credentials where - parseJSON = withObject "Credentials" $ \v -> Credentials - <$> v .: "token" - <*> v .: "user" + parseJSON = genericParseJSON $ removePrefixOpts "credentials" data User = User { userUsername :: Text , userDisplayName :: Text - } deriving (Show) + } deriving (Generic, Show) instance FromJSON User where - parseJSON = withObject "User" $ \v -> User - <$> v .: "username" - <*> v .: "displayName" + parseJSON = genericParseJSON $ removePrefixOpts "user" {- login :: Text -> Text -> Req (Either [GQLError] Credentials) @@ -212,6 +216,7 @@ data SqueakError | GQLErrors [GQLError] deriving (Show) +-- TODO: doc instance FromJSON SqueakError where parseJSON = withObject "SqueakError" $ \v -> SqueakError <$> v .: "errorCode" @@ -220,6 +225,7 @@ instance FromJSON SqueakError where newtype SqueakErrorOr a = SqueakErrorOr (Either SqueakError a) deriving (Show) +-- TODO: doc instance FromJSON a => FromJSON (SqueakErrorOr a) where -- | Parse 'SqueakError' if @errorCode@ and @msg@ are present; otherwise, parse an 'a'. parseJSON v = SqueakErrorOr @@ -238,13 +244,10 @@ data Order = Order , orderTag :: Text , orderNumPages :: Int } - deriving (Show) + deriving (Generic, Show) instance FromJSON Order where - parseJSON = withObject "Order" $ \v -> Order - <$> v .: "id" - <*> v .: "tag" - <*> v .: "numPages" + parseJSON = genericParseJSON $ removePrefixOpts "order" createOrder :: (HasEndpointInfo m, MonadIO m) => Text -> [Text] -> m (Either SqueakError Order) createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> mkQueryWithVars