Server.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE RecordWildCards     #-}

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE TypeOperators       #-}

module Avers.Server
    ( serveAversCoreAPI, serveAversSessionAPI

    , credentialsObjId

    , module Avers.Server.Authorization
    ) where


import Control.Monad
import Control.Monad.Except
-- import Control.Monad.IO.Class
import Control.Monad.Trans.Either

import           Data.Text            (Text)
-- import qualified Data.Text            as T
import qualified Data.Text.Encoding   as T

import qualified Data.ByteString.Lazy as LBS


import Data.Monoid
import Data.Pool
-- import Data.Proxy
-- import Data.Maybe
import Data.Time
import Data.Aeson (encode, decode)
-- import Data.Aeson.TH (defaultOptions)

import Servant.API
import Servant.Server

import Avers
-- import Avers.TH
-- import Avers.Storage
import Avers.Storage.Expressions
import Avers.Types

import Avers.API

import Avers.Server.Authorization
import Avers.Server.Instances ()

import qualified Database.RethinkDB as R

import Network.HTTP.Types.Status

import Network.Wai
import Network.Wai.Handler.WebSockets (websocketsApp)
import qualified Network.WebSockets as WS

import Web.Cookie



-- | Convert the 'Credentials' into an 'ObjId' to which the ceredentials refer.
-- That's the object the client is authenticated as.
credentialsObjId :: Handle -> Credentials -> EitherT ServantErr IO ObjId
credentialsObjId aversH cred = do
    errOrObjId <- case cred of
        SessionIdCredential sId -> liftIO $ evalAvers aversH $
            sessionObjId <$> lookupSession sId

    case errOrObjId of
        Left _  -> left err401
        Right s -> pure s


failWith :: Text -> EitherT ServantErr IO b
failWith e = left $ err500
    { errBody = LBS.fromChunks [T.encodeUtf8 e] }


aversResult :: Either AversError a -> EitherT ServantErr IO a
aversResult res = case res of
    Left e -> case e of
        DatabaseError detail                  -> failWith $ "database " <> detail
        NotAuthorized                         -> failWith $ "Unauthorized"
        DocumentNotFound _                    -> failWith $ "NotFound"
        UnknownObjectType detail              -> failWith $ "unknown object " <> detail
        ObjectNotFound _                      -> failWith $ "NotFound"
        ParseError _ detail                   -> failWith $ "parse " <> detail
        PatchError (UnknownPatchError detail) -> failWith $ "patch " <> detail
        AversError detail                     -> failWith $ "avers " <> detail
        InternalError ie                      -> aversResult (Left ie)
    Right r -> pure r


reqAvers :: Handle -> Avers a -> EitherT ServantErr IO a
reqAvers aversH m = liftIO (evalAvers aversH m) >>= aversResult



serveAversCoreAPI :: Handle -> Authorizations -> Server AversCoreAPI
serveAversCoreAPI aversH auth =
         serveCreateObject
    :<|> serveLookupObject
    :<|> servePatchObject
    :<|> serveDeleteObject
    :<|> serveLookupPatch
    :<|> serveObjectChanges
    :<|> serveCreateRelease
    :<|> serveLookupRelease
    :<|> serveLookupLatestRelease
    :<|> serveChangeSecret

  where

    ----------------------------------------------------------------------------
    -- CreateObject
    serveCreateObject cred body = do
        let objType = cobType body

        runAuthorization aversH $
            createObjectAuthz auth cred objType


        createdBy <- credentialsObjId aversH cred
        objId <- reqAvers aversH $ do
            SomeObjectType ot <- lookupObjectType objType
            content <- case parseValueAs ot (cobContent body) of
                Left e  -> throwError e
                Right x -> pure x

            createObject ot createdBy content

        pure $ CreateObjectResponse objId (cobType body) (cobContent body)


    ----------------------------------------------------------------------------
    -- LookupObject
    serveLookupObject objId cred = do
        runAuthorization aversH $
            lookupObjectAuthz auth cred objId


        (Object{..}, Snapshot{..}) <- reqAvers aversH $ do
            object <- lookupObject objId
            snapshot <- lookupLatestSnapshot (BaseObjectId objId)

            pure (object, snapshot)

        pure $ LookupObjectResponse
            { lorId = objId
            , lorType = objectType
            , lorCreatedAt = objectCreatedAt
            , lorCreatedBy = objectCreatedBy
            , lorRevisionId = snapshotRevisionId
            , lorContent = snapshotContent
            }

    ----------------------------------------------------------------------------
    -- PatchObject
    servePatchObject objId cred body = do
        -- runAuthorization aversH $
        --     lookupObjectAuthz auth cred objId


        authorObjId <- credentialsObjId aversH cred
        (previousPatches, numProcessedOperations, resultingPatches) <- reqAvers aversH $ do
            applyObjectUpdates
                (BaseObjectId objId)
                (pobRevisionId body)
                authorObjId
                (pobOperations body)
                False

        pure $ PatchObjectResponse
            { porPreviousPatches = previousPatches
            , porNumProcessedOperations = numProcessedOperations
            , porResultingPatches = resultingPatches
            }

    serveDeleteObject _ _ = left err500
    serveLookupPatch _ _ _ = left err500


    ----------------------------------------------------------------------------
    -- ObjectChanges
    serveObjectChanges objId _cred req respond = respond $
        case websocketsApp WS.defaultConnectionOptions wsApp req of
            Nothing  -> responseLBS status500 [] "Failed"
            Just res -> res
      where
        wsApp pendingConnection = do
            connection <- WS.acceptRequest pendingConnection
            WS.forkPingThread connection 10

            revIdData <- WS.receiveData connection
            case decode revIdData of
                Nothing -> pure ()
                Just revId -> do
                    withResource (databaseHandlePool aversH) $ \handle -> do
                        token <- R.start handle $
                            R.SequenceChanges $
                            objectPatchSequenceE (BaseObjectId objId) revId maxBound

                        loop connection handle token

        loop :: WS.Connection -> R.Handle -> R.Token -> IO ()
        loop connection handle token = do
            res <- R.nextResult handle token :: IO (Either R.Error (R.Sequence R.ChangeNotification))
            case res of
                Left e -> print e
                Right (R.Done r) -> do
                    forM_ r $ \p ->
                        WS.sendTextData connection (encode $ R.cnNewValue p)

                Right (R.Partial _ r) -> do
                    forM_ r $ \p ->
                        WS.sendTextData connection (encode $ R.cnNewValue p)

                    R.continue handle token
                    loop connection handle token


    serveCreateRelease _ _ _ = left err500
    serveLookupRelease _ _ _ = left err500
    serveLookupLatestRelease _ _ = left err500
    serveChangeSecret _ _ = left err500




serveAversSessionAPI :: Handle -> Server AversSessionAPI
serveAversSessionAPI aversH =
         serveCreateSession
    :<|> serveLookupSession
    :<|> serveDeleteSession

  where

    sessionCookieName     = "session"
    sessionExpirationTime = 2 * 365 * 24 * 60 * 60

    mkSetCookie :: SessionId -> EitherT ServantErr IO SetCookie
    mkSetCookie sId = do
        now <- liftIO $ getCurrentTime
        pure $ def
            { setCookieName = sessionCookieName
            , setCookieValue = T.encodeUtf8 (unSessionId sId)
            , setCookiePath = Just "/"
            , setCookieExpires = Just $ addUTCTime sessionExpirationTime now
            , setCookieHttpOnly = True
            }


    ----------------------------------------------------------------------------
    -- CreateSession
    serveCreateSession body = do
        -- Verify the secret, fail if it is invalid.
        reqAvers aversH $ verifySecret (csbLogin body) (csbSecret body)

        -- Create a new Session and save it in the database.
        now <- liftIO $ getCurrentTime
        sessId <- SessionId <$> liftIO (newId 80)
        -- isSecure <- rqIsSecure <$> getRequest

        let session = Session sessId (ObjId $ unSecretId $ csbLogin body) now now
        reqAvers aversH $ saveSession session

        setCookie <- mkSetCookie sessId
        pure $ addHeader setCookie $ CreateSessionResponse
            { csrSessionId = sessId
            , csrSessionObjId = ObjId $ unSecretId $ csbLogin body
            }


    ----------------------------------------------------------------------------
    -- LookupSession
    serveLookupSession sId = do
        session <- reqAvers aversH $ lookupSession sId

        setCookie <- mkSetCookie sId
        pure $ addHeader setCookie $ LookupSessionResponse
            { lsrSessionId = sessionId session
            , lsrSessionObjId = sessionObjId session
            }

    ----------------------------------------------------------------------------
    -- DeleteSession
    serveDeleteSession sId = do
        reqAvers aversH $ dropSession sId

        pure $ addHeader (def
            { setCookieName = sessionCookieName
            , setCookieExpires = Just $ UTCTime (ModifiedJulianDay 0) 0
            }) ()