From ace0bee9d67f6d7e730948eeca18ef221a584e0c Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Fri, 26 Aug 2022 05:05:13 +0200 Subject: [PATCH] Rename to SqueakCtx, add stubs for authentication --- src/Lisa/Squeak.hs | 51 +++++++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs index 9230f4e..1180b83 100644 --- a/src/Lisa/Squeak.hs +++ b/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 @ 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!]!) \