Add login function

app/Main.hs

@@ -1,8 +1,10 @@
 module Main where
 
-import Web.Scotty (scotty)
+import Web.Spock (spock, runSpock)
 
-import Lisa (app)
+import Lisa (mkConfig, app)
 
 main :: IO ()
-main = scotty 8080 app
+main = do
+    cfg <- mkConfig
+    runSpock 8080 $ spock cfg app

lisa.cabal

@@ -32,10 +32,10 @@ library
   hs-source-dirs:
       src
   build-depends:
-      aeson >=2.0
+      Spock >=0.14
+    , aeson >=2.0
     , base >=4.7 && <5
     , req >=3.10
-    , scotty >=0.12
     , text >=1.0
     , time
   default-language: Haskell2010
@@ -48,11 +48,11 @@ executable lisa-exe
       app
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      aeson >=2.0
+      Spock >=0.14
+    , aeson >=2.0
     , base >=4.7 && <5
     , lisa
     , req >=3.10
-    , scotty >=0.12
     , text >=1.0
     , time
   default-language: Haskell2010
@@ -66,11 +66,11 @@ test-suite lisa-test
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      aeson >=2.0
+      Spock >=0.14
+    , aeson >=2.0
     , base >=4.7 && <5
     , lisa
     , req >=3.10
-    , scotty >=0.12
     , text >=1.0
     , time
   default-language: Haskell2010

package.yaml

@@ -23,7 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - aeson >= 2.0
 - req >= 3.10
-- scotty >= 0.12
+- Spock >= 0.14
 - text >= 1.0
 - time
 
@@ -40,7 +40,7 @@ executables:
     - -with-rtsopts=-N
     dependencies:
     - lisa
-    - scotty >= 0.12
+    - Spock >= 0.14
 
 tests:
   lisa-test:

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
+    get root $ do
-        html "<h1>It works!</h1><ul><li><a href='/lectures/search?query='>Vorlesungen</a></li></ul>"
+        html "<h1>It works!</h1><ul><li><a href='/lectures/search'>Vorlesungen</a></li></ul>"
     get "/lectures/search" $ do
-        query <- param "query"
+        query <- fromMaybe "" <$> param "query"
-        html $ "<form action='/lectures/search' method='GET'><input name='query' value='"  <> query <> "'><button type='submit'>Suchen</button></form>"
+        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)
+getAllLectures :: Req (Either [GQLError] [Lecture])
-getLectures = responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
+getAllLectures = fmap unLectures <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
     where q = "{ lectures { id displayName aliases } }"
 
-getDocuments :: Req (GQLReply Documents)
+getAllDocuments :: Req (Either [GQLError] [Document])
-getDocuments = responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQuery q) jsonResponse mempty
+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 } } } }"
+    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
+            ]

stack.yaml

@@ -17,8 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
+resolver: nightly-2022-08-19
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

stack.yaml.lock

@@ -6,8 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 619161
+    size: 630640
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/19.yaml
-    sha256: 7f47507fd037228a8d23cf830f5844e1f006221acebdd7cb49f2f5fb561e0546
+    sha256: a10f9e3f425aa803549f72b29adb0825ac68262b16140e855f5683b91c2bedfe
-  original:
+  original: nightly-2022-08-19
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml