diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs index 869d688..a3592fa 100644 --- a/src/Lisa/Squeak.hs +++ b/src/Lisa/Squeak.hs @@ -1,31 +1,59 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} 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.Text (Text) import Data.Time.Calendar (Day) -import Network.HTTP.Req (POST(..), ReqBodyJson(..), Req, http, https, port, jsonResponse, responseBody, req) +import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Req, Scheme, Url, defaultHttpConfig, http, https, port, jsonResponse, responseBody, req, runReq) -data GQLQuery = GQLQuery - { gqlQueryQuery :: Text - } +-- | 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 + getEndpointInfo :: m (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1)) + +-- | Debugging instance. Makes it possible to just 'getAllLectures' etc. from GHCi. +instance HasEndpointInfo IO where + -- getEndpointInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty) + getEndpointInfo = pure $ Left (http "localhost", port 8000) + +-- | Construct a GraphQL query that runs in 'm' and returns a 'result'. +mkQueryWithVars + :: (HasEndpointInfo m, MonadIO m, ToJSON v, FromJSON result) + => v -- ^ This field is sent as JSON in the @variables@ key. + -> Text + -> m (Either [GQLError] result) +mkQueryWithVars vars query = do + endpointInfo <- getEndpointInfo + let request = (case endpointInfo of + Left (httpUrl, httpOptions) -> req POST httpUrl payload jsonResponse httpOptions + Right (httpsUrl, httpsOptions) -> req POST httpsUrl payload jsonResponse httpsOptions) + response <- liftIO $ runReq defaultHttpConfig request + pure $ replyToEither $ responseBody response + where + payload = ReqBodyJson $ GQLQuery query vars + +-- | Construct a GraphQL query that runs in 'm' and returns a 'result' or a 'SqueakError'. +mkQuery + :: (HasEndpointInfo m, MonadIO m, FromJSON result) + => Text + -> m (Either [GQLError] result) +mkQuery = mkQueryWithVars $ object [] + +joinErrors :: Either [GQLError] (SqueakErrorOr a) -> Either SqueakError a +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) -instance ToJSON GQLQuery where - toJSON (GQLQuery query) = object - [ "query" .= query - ] - -data GQLQueryWithVars a = GQLQueryWithVars - { gqlQueryWithVarsQuery :: Text - , gqlQueryWithVarsVariables :: a - } - deriving (Show) - -instance ToJSON a => ToJSON (GQLQueryWithVars a) where - toJSON (GQLQueryWithVars query variables) = object +instance ToJSON v => ToJSON (GQLQuery v) where + toJSON (GQLQuery query variables) = object [ "query" .= query , "variables" .= variables ] @@ -114,19 +142,23 @@ instance FromJSON Lecture where <*> v .: "displayName" <*> v .: "aliases" -serverUrl = https "api.squeak-test.fsmi.uni-karlsruhe.de" +getAllLectures :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Lecture]) +getAllLectures = fmap unLectures <$> joinErrors <$> mkQuery + "{ lectures \ + \ { id displayName aliases } \ + \}" -getAllLectures :: Req (Either [GQLError] [Lecture]) -getAllLectures = fmap unLectures <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty - where q = "{ lectures { id displayName aliases } }" - -getAllDocuments :: Req (Either [GQLError] [Document]) -getAllDocuments = fmap unDocuments <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty - where q = "{ documents(filters: []) { results { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } } } }" +getAllDocuments :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Document]) +getAllDocuments = fmap unDocuments <$> joinErrors <$> mkQuery + "{ documents(filters: []) \ + \ { results \ + \ { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } } \ + \ } \ + \}" -- Mutations -data LoginResult = LoginResult { unLoginResult :: Credentials } +data LoginResult = LoginResult { unLoginResult :: SqueakErrorOr Credentials } deriving (Show) instance FromJSON LoginResult where @@ -153,6 +185,7 @@ instance FromJSON User where <$> v .: "username" <*> v .: "displayName" +{- login :: Text -> Text -> Req (Either [GQLError] Credentials) login username password = fmap unLoginResult <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQueryWithVars q vars) jsonResponse mempty where q = "mutation LoginUser($username: String!, $password: String!) { login(username: $username, password: $password) { ... on Credentials { token user { username displayName } } } }" @@ -160,6 +193,17 @@ login username password = fmap unLoginResult <$> replyToEither <$> responseBody [ "username" .= username , "password" .= password ] +-} + +login :: (HasEndpointInfo m, MonadIO m) => Text -> Text -> m (Either SqueakError Credentials) +login username password = joinErrors <$> fmap unLoginResult <$> mkQueryWithVars + (object ["username" .= username, "password" .= password]) + "mutation LoginUser($username: String!, $password: String!) \ + \ { login(username: $username, password: $password) \ + \ { __typename \ + \ ... on Error { errorCode msg } \ + \ ... on Credentials { token user { username displayName } } } \ + \ }" data SqueakError = SqueakError @@ -202,18 +246,11 @@ instance FromJSON Order where <*> v .: "tag" <*> v .: "numPages" -joinErrors :: Either [GQLError] (SqueakErrorOr a) -> Either SqueakError a -joinErrors (Left errors) = Left $ GQLErrors errors -joinErrors (Right (SqueakErrorOr inner)) = inner - -createOrder :: Text -> [Text] -> Req (Either SqueakError Order) -createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQueryWithVars q vars) jsonResponse mempty - where q = "mutation CreateOrder($tag: String!, $documents: [DocumentId!]!) \ - \ { createOrder(tag: $tag, documents: $documents) \ - \ { ... on Error { errorCode msg } \ - \ ... on Order { id tag numPages } \ - \ } }" - vars = object - [ "tag" .= tag - , "documents" .= documents - ] +createOrder :: (HasEndpointInfo m, MonadIO m) => Text -> [Text] -> m (Either SqueakError Order) +createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> mkQueryWithVars + (object ["tag" .= tag, "documents" .= documents]) + "mutation CreateOrder($tag: String!, $documents: [DocumentId!]!) \ + \ { createOrder(tag: $tag, documents: $documents) \ + \ { ... on Error { errorCode msg } \ + \ ... on Order { id tag numPages } \ + \ } }"