module Avers.Server
( serveAversCoreAPI, serveAversSessionAPI
, credentialsObjId
, module Avers.Server.Authorization
) where
import Control.Monad
import Control.Monad.Except
import Control.Concurrent
import Control.Concurrent.STM
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.Set as S
import Data.Monoid
import Data.Time
import Data.Aeson (ToJSON, encode, decode)
import Crypto.Hash.SHA256 (hashlazy)
import Servant.API hiding (Patch)
import Servant.Server
import Avers
import Avers.API
import Avers.Server.Authorization
import Avers.Server.Instances ()
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Handler.WebSockets (websocketsApp)
import qualified Network.WebSockets as WS
import Web.Cookie
import Prelude
etagVersion :: Text
etagVersion = "v0"
credentialsObjId :: Handle -> Credentials -> ExceptT ServantErr IO ObjId
credentialsObjId aversH cred = do
errOrObjId <- case cred of
SessionIdCredential sId -> liftIO $ evalAvers aversH $
sessionObjId <$> lookupSession sId
case errOrObjId of
Left _ -> throwError err401
Right s -> pure s
failWith :: Text -> ExceptT ServantErr IO b
failWith e = throwError $ err500
{ errBody = LBS.fromChunks [T.encodeUtf8 e] }
aversResult :: Either AversError a -> ExceptT 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 -> ExceptT ServantErr IO a
reqAvers aversH m = liftIO (evalAvers aversH m) >>= aversResult
cacheableResponse :: (ToJSON a) => Maybe Text -> a -> ExceptT ServantErr IO (Cacheable a)
cacheableResponse mbValidationToken a = do
let etag = T.decodeUtf8 $ BS64.encode $ hashlazy $ encode a
if mbValidationToken == Just (etagVersion <> ":" <> etag)
then throwError err304
else pure $ addHeader "no-cache, public, max-age=63072000"
$ addHeader (etagVersion <> ":" <> etag) a
serveAversCoreAPI :: Handle -> Authorizations -> Server AversCoreAPI
serveAversCoreAPI aversH auth =
serveCreateObject
:<|> serveLookupObject
:<|> servePatchObject
:<|> serveDeleteObject
:<|> serveLookupPatch
:<|> serveObjectChanges
:<|> serveCreateRelease
:<|> serveLookupRelease
:<|> serveLookupLatestRelease
:<|> serveFeed
:<|> serveChangeSecret
where
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)
serveLookupObject objId cred validationToken = do
runAuthorization aversH $
lookupObjectAuthz auth cred objId
(Object{..}, Snapshot{..}) <- reqAvers aversH $ do
object <- lookupObject objId
snapshot <- lookupLatestSnapshot (BaseObjectId objId)
pure (object, snapshot)
cacheableResponse validationToken $ LookupObjectResponse
{ lorId = objId
, lorType = objectType
, lorCreatedAt = objectCreatedAt
, lorCreatedBy = objectCreatedBy
, lorRevisionId = snapshotRevisionId
, lorContent = snapshotContent
}
servePatchObject objId cred body = do
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 _ _ = throwError err500
serveLookupPatch objId revId _cred validationToken = do
patch <- reqAvers aversH $ lookupPatch (BaseObjectId objId) revId
cacheableResponse validationToken patch
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
chan <- changeChannel aversH
loop connection chan
loop :: WS.Connection -> TChan Change -> IO ()
loop connection chan = do
change <- atomically $ readTChan chan
case change of
(CPatch patch) -> when (patchObjectId patch == BaseObjectId objId) $
WS.sendTextData connection (encode patch)
loop connection chan
serveCreateRelease _ _ _ = throwError err500
serveLookupRelease _ _ _ _ = throwError err500
serveLookupLatestRelease _ _ _ = throwError err500
serveFeed _cred req respond = respond $
case websocketsApp WS.defaultConnectionOptions wsApp req of
Nothing -> responseLBS status500 [] "This is a WebSocket endpoint"
Just res -> res
where
wsApp pendingConnection = do
subscriptions <- newTVarIO S.empty
connection <- WS.acceptRequest pendingConnection
WS.forkPingThread connection 10
void $ forkIO $ forever $ do
msg <- WS.receiveData connection
case decode msg of
Nothing -> pure ()
Just (IncludeObjectChanges objId) ->
atomically $ modifyTVar' subscriptions $ S.insert $ BaseObjectId objId
chan <- changeChannel aversH
loop connection subscriptions chan
loop :: WS.Connection -> TVar (S.Set ObjectId) -> TChan Change -> IO ()
loop connection subscriptions chan = do
change <- atomically $ readTChan chan
subs <- atomically $ readTVar subscriptions
case change of
(CPatch p) -> when (S.member (patchObjectId p) subs) $
WS.sendTextData connection (encode change)
loop connection subscriptions chan
serveChangeSecret _ _ = throwError err500
serveAversSessionAPI :: Handle -> Server AversSessionAPI
serveAversSessionAPI aversH =
serveCreateSession
:<|> serveLookupSession
:<|> serveDeleteSession
where
sessionCookieName = "session"
sessionExpirationTime = 2 * 365 * 24 * 60 * 60
mkSetCookie :: SessionId -> ExceptT 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
}
serveCreateSession body = do
reqAvers aversH $ verifySecret (csbLogin body) (csbSecret body)
now <- liftIO $ getCurrentTime
sessId <- SessionId <$> liftIO (newId 80)
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
}
serveLookupSession sId = do
session <- reqAvers aversH $ lookupSession sId
setCookie <- mkSetCookie sId
pure $ addHeader setCookie $ LookupSessionResponse
{ lsrSessionId = sessionId session
, lsrSessionObjId = sessionObjId session
}
serveDeleteSession sId = do
reqAvers aversH $ dropSession sId
pure $ addHeader (def
{ setCookieName = sessionCookieName
, setCookieExpires = Just $ UTCTime (ModifiedJulianDay 0) 0
}) ()