diff --git a/app/Main.hs b/app/Main.hs
index 072207d..79cacea 100644
--- a/app/Main.hs
+++ b/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
diff --git a/lisa.cabal b/lisa.cabal
index 2f2b4ce..c9e7a25 100644
--- a/lisa.cabal
+++ b/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
diff --git a/package.yaml b/package.yaml
index 0d79d35..3aa6e6b 100644
--- a/package.yaml
+++ b/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:
diff --git a/src/Lisa.hs b/src/Lisa.hs
index 2722b2e..b361c85 100644
--- a/src/Lisa.hs
+++ b/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 "
It works!
"
+ get root $ do
+ html "It works!
"
get "/lectures/search" $ do
- query <- param "query"
- html $ ""
+ query <- fromMaybe "" <$> param "query"
+ html $ "" <> query <> "
"
diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs
index 06f332e..65c24d1 100644
--- a/src/Lisa/Squeak.hs
+++ b/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
+ ]
diff --git a/stack.yaml b/stack.yaml
index 56d2355..2b96341 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -17,8 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
- url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
+resolver: nightly-2022-08-19
# User packages to be built.
# Various formats can be used as shown in the example below.
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 84bf18d..0b0adaa 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -6,8 +6,7 @@
packages: []
snapshots:
- completed:
- size: 619161
- url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
- sha256: 7f47507fd037228a8d23cf830f5844e1f006221acebdd7cb49f2f5fb561e0546
- original:
- url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
+ size: 630640
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/19.yaml
+ sha256: a10f9e3f425aa803549f72b29adb0825ac68262b16140e855f5683b91c2bedfe
+ original: nightly-2022-08-19