lisa/src/Lisa/Squeak.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Lisa.Squeak where

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, 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 '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 SqueakCtx IO where
    -- getEndpointInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty)
    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
    :: (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
    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 <JWT>@ header.
        mkAuthHeader = maybe mempty $ header "Authorization" . ("Bearer " <>) . encodeUtf8

-- | Construct a GraphQL query that runs in 'm' and returns a 'result' or a 'SqueakError'.
mkQuery
    :: (SqueakCtx m, MonadIO m, FromJSON result)
    => Text
    -> m (Either [GQLError] result)
mkQuery = mkQueryWithVars $ object []

joinErrors :: Either [GQLError] (SqueakErrorOr a) -> Either SqueakError a
joinErrors (Left errors) = Left $ GQLErrors errors
joinErrors (Right (SqueakErrorOr inner)) = inner

-- ^ A GraphQL query with a bunch of variables.
data GQLQuery v = GQLQuery
    { gqlQueryQuery     :: Text
    , gqlQueryVariables :: v
    }
    deriving (Generic, Show)

instance ToJSON v => ToJSON (GQLQuery v) where
    toJSON = genericToJSON $ removePrefixOpts "gqlQuery"

data GQLReply a = GQLReply
    { gqlReplyData :: Maybe a
    , gqlReplyErrors :: Maybe [GQLError]
    }
    deriving (Generic, Show)

instance FromJSON a => FromJSON (GQLReply a) where
    parseJSON = genericParseJSON $ removePrefixOpts "gqlReply"

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
    }
    deriving (Generic, Show)

instance FromJSON GQLError where
    parseJSON = genericParseJSON $ removePrefixOpts "gqlError"

-- TODO: doc
data Documents = Documents { unDocuments :: [Document] }
    deriving (Show)

-- TODO: doc
instance FromJSON Documents where
    parseJSON = withObject "Documents" $ \v -> Documents
        <$> ((v .: "documents") >>= (.: "results"))

-- | Helper for automatically writing 'FromJSON' instances.
--
-- >>> removePrefixModifier "document" "documentId"
-- "id"
-- >>> removePrefixModifier "document" "documentPublicComment"
-- "publicComment"
removePrefixModifier :: String -> String -> String
removePrefixModifier prefix = lowercaseFirst . stripPrefix prefix
    where
        stripPrefix [] word = word
        stripPrefix (p:ps) (c:cs)
            | p == c    = stripPrefix ps cs
            | otherwise = error $ "Invalid prefix " ++ (p:ps) ++ " (" ++ prefix ++ ") for key " ++ (c:cs)
        stripPrefix _ [] = error $ "Prefix " ++ prefix ++ " is too long"

        lowercaseFirst (c:cs) = Char.toLower c : cs
        lowercaseFirst [] = error $ "Prefix " ++ prefix ++ " ate all my input"

removePrefixOpts :: String -> Options
removePrefixOpts prefix = defaultOptions { fieldLabelModifier = removePrefixModifier prefix }

data Document = Document
    { documentId            :: Text
    , documentDate          :: Day
    , documentSemester      :: Text
    , documentPublicComment :: Maybe Text
    , documentFaculty       :: Faculty
    , documentLectures      :: [Lecture]
    , documentDownloadable  :: Bool
    , documentType          :: Text
    , documentNumPages      :: Int
    }
    deriving (Show, Generic)

instance FromJSON Document where
    parseJSON = genericParseJSON $ removePrefixOpts "document"

data Faculty = Faculty
    { facultyId          :: Text
    , facultyDisplayName :: Text
    }
    deriving (Generic, Show)

instance FromJSON Faculty where
    parseJSON = genericParseJSON $ removePrefixOpts "faculty"

data Lectures = Lectures { unLectures :: [Lecture] }
    deriving (Generic, Show)

instance FromJSON Lectures where
    parseJSON = genericParseJSON $ removePrefixOpts "un"

data Lecture = Lecture
    { lectureId          :: Text
    , lectureDisplayName :: Text
    , lectureAliases     :: [Text]
    }
    deriving (Generic, Show)

instance FromJSON Lecture where
    parseJSON = genericParseJSON $ removePrefixOpts "lecture"

getAllLectures :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Lecture])
getAllLectures = fmap unLectures <$> joinErrors <$> mkQuery
    "{ lectures \
    \  { id displayName aliases } \
    \}"

getAllDocuments :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Document])
getAllDocuments = fmap unDocuments <$> joinErrors <$> mkQuery
    "{ documents(filters: []) \
    \  { results \
    \    { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } type numPages } \
    \  } \
    \}"

getDocumentsByLectureId :: (SqueakCtx m, MonadIO m) => Text -> m (Either SqueakError [Document])
getDocumentsByLectureId lecture = fmap unDocuments <$> joinErrors <$> mkQueryWithVars
    (object ["lecture" .= lecture])
    "query DocumentsByLectureId($lecture: LectureId!) \
    \ { documents(filters: [{ lectures: [$lecture] }]) \
    \  { results \
    \    { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } type numPages } \
    \  } \
    \}"

-- Mutations

data LoginResult = LoginResult { unLoginResult :: SqueakErrorOr Credentials }
    deriving (Show)

instance FromJSON LoginResult where
    parseJSON = withObject "LoginResult" $ \v -> LoginResult
        <$> v .: "login"

data Credentials = Credentials
    { credentialsToken :: Text
    , credentialsUser  :: User
    } deriving (Generic, Show)

instance FromJSON Credentials where
    parseJSON = genericParseJSON $ removePrefixOpts "credentials"

data User = User
    { userUsername    :: Text
    , userDisplayName :: Text
    } deriving (Generic, Show)

instance FromJSON User where
    parseJSON = genericParseJSON $ removePrefixOpts "user"

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!) \
    \ { login(username: $username, password: $password) \
    \    { __typename \
    \      ... on Error { errorCode msg } \
    \      ... on Credentials { token user { username displayName } } } \
    \ }"

data SqueakError
    = SqueakError
        Text -- ^ Error code
        Text -- ^ Human-readable message
    | GQLErrors [GQLError]
    deriving (Show)

-- TODO: doc
instance FromJSON SqueakError where
    parseJSON = withObject "SqueakError" $ \v -> SqueakError
        <$> v .: "errorCode"
        <*> v .: "msg"

newtype SqueakErrorOr a = SqueakErrorOr (Either SqueakError a)
    deriving (Show)

-- TODO: doc
instance FromJSON a => FromJSON (SqueakErrorOr a) where
    -- | Parse 'SqueakError' if @errorCode@ and @msg@ are present; otherwise, parse an 'a'.
    parseJSON v = SqueakErrorOr
        <$> ((Left <$> parseJSON v)
        <|> (Right <$> parseJSON v))

data CreateOrderResult = CreateOrderResult { unCreateOrderResult :: SqueakErrorOr Order }
    deriving (Show)

instance (FromJSON CreateOrderResult) where
    parseJSON = withObject "CreateOrderResult" $ \v -> CreateOrderResult
        <$> v .: "createOrder"

data Order = Order
    { orderId       :: Text
    , orderTag      :: Text
    , orderNumPages :: Int
    }
    deriving (Generic, Show)

instance FromJSON Order where
    parseJSON = genericParseJSON $ removePrefixOpts "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!]!) \
    \ { createOrder(tag: $tag, documents: $documents) \
    \ { ... on Error { errorCode msg } \
    \   ... on Order { id tag numPages } \
    \ } }"