Add login function

src/Lisa.hs

@@ -2,15 +2,22 @@
 
 module Lisa
     ( app
+    , mkConfig
     ) where
 
 import Data.Maybe (fromMaybe)
-import Web.Scotty (ScottyM, get, html, param, rescue)
+import Web.Spock (SpockM, get, html, param, root)
+import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg)
 
-app :: ScottyM ()
+data Session = Session
+
+mkConfig :: IO (SpockCfg () Session ())
+mkConfig = defaultSpockCfg Session PCNoDatabase ()
+
+app :: SpockM () Session () ()
 app = do
-    get "/" $ do
-        html "<h1>It works!</h1><ul><li><a href='/lectures/search?query='>Vorlesungen</a></li></ul>"
+    get root $ do
+        html "<h1>It works!</h1><ul><li><a href='/lectures/search'>Vorlesungen</a></li></ul>"
     get "/lectures/search" $ do
-        query <- param "query"
-        html $ "<form action='/lectures/search' method='GET'><input name='query' value='"  <> query <> "'><button type='submit'>Suchen</button></form>"
+        query <- fromMaybe "" <$> param "query"
+        html $ "<h1>" <> query <> "</h1><form action='/lectures/search' method='GET'><input name='query' value='"  <> query <> "'><button type='submit'>Suchen</button></form>"

src/Lisa/Squeak.hs

@@ -5,15 +5,29 @@ module Lisa.Squeak where
 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, https, jsonResponse, responseBody, req)
+import Network.HTTP.Req (POST(..), ReqBodyJson(..), Req, http, https, port, jsonResponse, responseBody, req)
 
 data GQLQuery = GQLQuery
-    { gqlQueryQuery :: Text
+    { gqlQueryQuery     :: Text
     }
     deriving (Show)
 
 instance ToJSON GQLQuery where
-    toJSON (GQLQuery q) = object ["query" .= q]
+    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
+        [ "query" .= query
+        , "variables" .= variables
+        ]
 
 data GQLReply a = GQLReply
     { gqlReplyData :: Maybe a
@@ -26,6 +40,11 @@ instance FromJSON a => FromJSON (GQLReply a) where
         <$> v .: "data"
         <*> v .:? "errors"
 
+replyToEither :: GQLReply a -> Either [GQLError] a
+replyToEither (GQLReply (Just data') _)  = Right data'
+replyToEither (GQLReply _ (Just errors)) = Left errors
+replyToEither _                          = error "Invalid GQLReply: Neither 'data' nor 'errors'"
+
 data GQLError = GQLError
     { gqlErrorMessage :: Text
     }
@@ -96,10 +115,47 @@ instance FromJSON Lecture where
 
 serverUrl = https "api.squeak-test.fsmi.uni-karlsruhe.de"
 
-getLectures :: Req (GQLReply Lectures)
-getLectures = responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
+getAllLectures :: Req (Either [GQLError] [Lecture])
+getAllLectures = fmap unLectures <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
     where q = "{ lectures { id displayName aliases } }"
 
-getDocuments :: Req (GQLReply Documents)
-getDocuments = 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 } } } }"
+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 } } } }"
+
+-- Mutations
+
+data LoginResult = LoginResult { unLoginResult :: Credentials }
+    deriving (Show)
+
+instance FromJSON LoginResult where
+    parseJSON = withObject "LoginResult" $ \v -> LoginResult
+        <$> v .: "login"
+
+data Credentials = Credentials
+    { credentialsToken :: Text
+    , credentialsUser  :: User
+    } deriving (Show)
+
+instance FromJSON Credentials where
+    parseJSON = withObject "Credentials" $ \v -> Credentials
+        <$> v .: "token"
+        <*> v .: "user"
+
+data User = User
+    { userUsername    :: Text
+    , userDisplayName :: Text
+    } deriving (Show)
+
+instance FromJSON User where
+    parseJSON = withObject "User" $ \v -> User
+        <$> 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 } } } }"
+          vars = object
+            [ "username" .= username
+            , "password" .= password
+            ]