From c8591dc07b8b674e07eb7c546d3675dd1a12b790 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Wed, 24 Aug 2022 11:54:54 +0200 Subject: [PATCH] Add login function --- app/Main.hs | 8 ++++-- lisa.cabal | 12 ++++---- package.yaml | 4 +-- src/Lisa.hs | 19 ++++++++---- src/Lisa/Squeak.hs | 72 ++++++++++++++++++++++++++++++++++++++++------ stack.yaml | 3 +- stack.yaml.lock | 9 +++--- 7 files changed, 95 insertions(+), 32 deletions(-) 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