Refactor queries

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
+-- | Dependency Inversion for monads that can run requests.
-    { gqlQueryQuery     :: Text
+-- 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
+instance ToJSON v => ToJSON (GQLQuery v) where
-    toJSON (GQLQuery query) = object
+    toJSON (GQLQuery query variables) = 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
         [ "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])
+getAllDocuments :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Document])
-getAllLectures = fmap unLectures <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
+getAllDocuments = fmap unDocuments <$> joinErrors <$> mkQuery
-    where q = "{ lectures { id displayName aliases } }"
+    "{ documents(filters: []) \
-
+    \  { results \
-getAllDocuments :: Req (Either [GQLError] [Document])
+    \    { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } } \
-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 } } } }"
+    \}"
 
 -- 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
+createOrder :: (HasEndpointInfo m, MonadIO m) => Text -> [Text] -> m (Either SqueakError Order)
-joinErrors (Left errors) = Left $ GQLErrors errors
+createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> mkQueryWithVars
-joinErrors (Right (SqueakErrorOr inner)) = inner
+    (object ["tag" .= tag, "documents" .= documents])
-
+    "mutation CreateOrder($tag: String!, $documents: [DocumentId!]!) \
-createOrder :: Text -> [Text] -> Req (Either SqueakError Order)
+    \ { createOrder(tag: $tag, documents: $documents) \
-createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQueryWithVars q vars) jsonResponse mempty
+    \ { ... on Error { errorCode msg } \
-    where q = "mutation CreateOrder($tag: String!, $documents: [DocumentId!]!) \
+    \   ... on Order { id tag numPages } \
-              \ { createOrder(tag: $tag, documents: $documents) \
+    \ } }"
-              \ { ... on Error { errorCode msg } \
-              \   ... on Order { id tag numPages } \
-              \ } }"
-          vars = object
-            [ "tag" .= tag
-            , "documents" .= documents
-            ]