Rename to SqueakCtx, add stubs for authentication

src/Lisa/Squeak.hs

@@ -9,41 +9,50 @@ import Control.Applicative ((<|>))
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Aeson (FromJSON(parseJSON), Options(fieldLabelModifier), ToJSON(toJSON), (.:), (.=), defaultOptions, genericParseJSON, genericToJSON, object, withObject)
 import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Calendar (Day)
 import GHC.Generics (Generic)
-import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Url, defaultHttpConfig, http, port, jsonResponse, responseBody, req, runReq)
+import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Url, defaultHttpConfig, header, http, port, jsonResponse, responseBody, req, runReq)
 
 import qualified Data.Char as Char
+import qualified Data.Text as 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))
+-- By requiring 'SqueakCtx' and 'MonadIO' for functions that perform requests we don't need to import anything from Scotty.
+class SqueakCtx m where
+    -- | 'Url' and possibly other 'Option's regarding the Squeak API server.
+    getLocationInfo :: m (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
+    -- | If available, an authentication token obtained by 'login'.
+    getAuthToken :: m (Maybe Text)
 
 -- | Debugging instance. Makes it possible to just 'getAllLectures' etc. from GHCi.
-instance HasEndpointInfo IO where
+instance SqueakCtx IO where
     -- getEndpointInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty)
-    getEndpointInfo = pure $ Left (http "localhost", port 8000)
+    getLocationInfo = pure $ Left (http "localhost", port 8000)
+    getAuthToken = Just . Text.pack <$> getLine
 
 -- | Construct a GraphQL query that runs in 'm' and returns a 'result'.
 mkQueryWithVars
-    :: (HasEndpointInfo m, MonadIO m, ToJSON v, FromJSON result)
+    :: (SqueakCtx 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)
+    locationInfo <- getLocationInfo
+    authToken <- getAuthToken
+    let request = (case locationInfo of
+                    Left (httpUrl, httpOptions) -> req POST httpUrl payload jsonResponse (httpOptions <> mkAuthHeader authToken)
+                    Right (httpsUrl, httpsOptions) -> req POST httpsUrl payload jsonResponse (httpsOptions <> mkAuthHeader authToken))
     response <- liftIO $ runReq defaultHttpConfig request
     pure $ replyToEither $ responseBody response
     where
         payload = ReqBodyJson $ GQLQuery query vars
+        -- If no token is provided, no options are added ('mempty'). Otherwise, add an @Authorization: Bearer <JWT>@ header.
+        mkAuthHeader = maybe mempty $ header "Authorization" . ("Bearer " <>) . encodeUtf8
 
 -- | Construct a GraphQL query that runs in 'm' and returns a 'result' or a 'SqueakError'.
 mkQuery
-    :: (HasEndpointInfo m, MonadIO m, FromJSON result)
+    :: (SqueakCtx m, MonadIO m, FromJSON result)
     => Text
     -> m (Either [GQLError] result)
 mkQuery = mkQueryWithVars $ object []
@@ -152,13 +161,13 @@ data Lecture = Lecture
 instance FromJSON Lecture where
     parseJSON = genericParseJSON $ removePrefixOpts "lecture"
 
-getAllLectures :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Lecture])
+getAllLectures :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Lecture])
 getAllLectures = fmap unLectures <$> joinErrors <$> mkQuery
     "{ lectures \
     \  { id displayName aliases } \
     \}"
 
-getAllDocuments :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Document])
+getAllDocuments :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Document])
 getAllDocuments = fmap unDocuments <$> joinErrors <$> mkQuery
     "{ documents(filters: []) \
     \  { results \
@@ -191,17 +200,7 @@ data User = User
 instance FromJSON User where
     parseJSON = genericParseJSON $ removePrefixOpts "user"
 
-{-
-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 } } } }"
-          vars = object
-            [ "username" .= username
-            , "password" .= password
-            ]
--}
-
-login :: (HasEndpointInfo m, MonadIO m) => Text -> Text -> m (Either SqueakError Credentials)
+login :: (SqueakCtx 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!) \
@@ -251,7 +250,7 @@ data Order = Order
 instance FromJSON Order where
     parseJSON = genericParseJSON $ removePrefixOpts "order"
 
-createOrder :: (HasEndpointInfo m, MonadIO m) => Text -> [Text] -> m (Either SqueakError Order)
+createOrder :: (SqueakCtx 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!]!) \