avers-server 0.0.3 → 0.0.4
raw patch · 4 files changed
+50/−46 lines, 4 files
Files
- avers-server.cabal +1/−1
- src/Avers/Server.hs +15/−16
- src/Avers/Server/Authorization.hs +4/−4
- src/Avers/Server/Instances.hs +30/−25
avers-server.cabal view
@@ -1,5 +1,5 @@ name: avers-server-version: 0.0.3+version: 0.0.4 synopsis: Server implementation of the Avers API description: See README.md homepage: http://github.com/wereHamster/avers-server
src/Avers/Server.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} module Avers.Server ( serveAversCoreAPI, serveAversSessionAPI@@ -18,8 +19,6 @@ import Control.Monad import Control.Monad.Except--- import Control.Monad.IO.Class-import Control.Monad.Trans.Either import Control.Concurrent import Control.Concurrent.STM@@ -77,23 +76,23 @@ -- | 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 :: 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 _ -> left err401+ Left _ -> throwError err401 Right s -> pure s -failWith :: Text -> EitherT ServantErr IO b-failWith e = left $ err500+failWith :: Text -> ExceptT ServantErr IO b+failWith e = throwError $ err500 { errBody = LBS.fromChunks [T.encodeUtf8 e] } -aversResult :: Either AversError a -> EitherT ServantErr IO a+aversResult :: Either AversError a -> ExceptT ServantErr IO a aversResult res = case res of Left e -> case e of DatabaseError detail -> failWith $ "database " <> detail@@ -108,15 +107,15 @@ Right r -> pure r -reqAvers :: Handle -> Avers a -> EitherT ServantErr IO a+reqAvers :: Handle -> Avers a -> ExceptT ServantErr IO a reqAvers aversH m = liftIO (evalAvers aversH m) >>= aversResult -cacheableResponse :: (ToJSON a) => Maybe Text -> a -> EitherT ServantErr IO (Cacheable a)+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 left $ err304+ then throwError err304 else pure $ addHeader "no-cache, public, max-age=63072000" $ addHeader (etagVersion <> ":" <> etag) a @@ -202,7 +201,7 @@ , porResultingPatches = resultingPatches } - serveDeleteObject _ _ = left err500+ serveDeleteObject _ _ = throwError err500 ----------------------------------------------------------------------------@@ -239,9 +238,9 @@ - serveCreateRelease _ _ _ = left err500- serveLookupRelease _ _ _ _ = left err500- serveLookupLatestRelease _ _ _ = left err500+ serveCreateRelease _ _ _ = throwError err500+ serveLookupRelease _ _ _ _ = throwError err500+ serveLookupLatestRelease _ _ _ = throwError err500 ----------------------------------------------------------------------------@@ -277,7 +276,7 @@ loop connection subscriptions chan - serveChangeSecret _ _ = left err500+ serveChangeSecret _ _ = throwError err500 @@ -293,7 +292,7 @@ sessionCookieName = "session" sessionExpirationTime = 2 * 365 * 24 * 60 * 60 - mkSetCookie :: SessionId -> EitherT ServantErr IO SetCookie+ mkSetCookie :: SessionId -> ExceptT ServantErr IO SetCookie mkSetCookie sId = do now <- liftIO $ getCurrentTime pure $ def
src/Avers/Server/Authorization.hs view
@@ -11,7 +11,7 @@ import Control.Monad.IO.Class-import Control.Monad.Trans.Either+import Control.Monad.Except import Data.Text (Text) @@ -64,16 +64,16 @@ -------------------------------------------------------------------------------- -- | Run the authorization logic inside of the Servant monad. -runAuthorization :: Handle -> Authz -> EitherT ServantErr IO ()+runAuthorization :: Handle -> Authz -> ExceptT ServantErr IO () runAuthorization _ [] = pure () runAuthorization aversH (x:xs) = do res <- liftIO $ evalAvers aversH x case res of- Left _ -> left $ err500+ Left _ -> throwError err500 Right r -> case r of ContinueR -> runAuthorization aversH xs AllowR -> pure ()- RejectR -> left $ err401+ RejectR -> throwError err401
src/Avers/Server/Instances.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Avers.Server.Instances where @@ -22,43 +23,47 @@ import Servant.Server import Servant.Server.Internal -import Network.HTTP.Types.Status- import Network.Wai import Web.Cookie -instance (HasServer sublayout) => HasServer (Credentials :> sublayout) where+instance (HasServer sublayout context) => HasServer (Credentials :> sublayout) context where type ServerT (Credentials :> sublayout) m = Credentials -> ServerT sublayout m - route Proxy subserver request respond = do- let mbCookieHeaders = lookup "cookie" (requestHeaders request)- mbSessionIdText = fromText =<< lookup "session" =<< fmap parseCookiesText mbCookieHeaders- mbCredentials = fmap (SessionIdCredential . SessionId) mbSessionIdText+ route Proxy context subserver = WithRequest $ \request ->+ route (Proxy :: Proxy sublayout) context (addCapture subserver $ do+ let mbCookieHeaders = lookup "cookie" (requestHeaders request)+ mbSessionIdText = lookup "session" =<< fmap parseCookiesText mbCookieHeaders - case mbCredentials of- Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""- Just cred -> route (Proxy :: Proxy sublayout) (subserver cred) request respond+ pure $ case mbSessionIdText of+ Nothing -> FailFatal err401+ Just sessionIdText -> case parseQueryParam sessionIdText of+ Left _ -> FailFatal err401+ Right sId -> Route $ (SessionIdCredential $ SessionId sId)+ ) -instance (HasServer sublayout) => HasServer (SessionId :> sublayout) where+instance (HasServer sublayout context) => HasServer (SessionId :> sublayout) context where type ServerT (SessionId :> sublayout) m = SessionId -> ServerT sublayout m - route Proxy subserver request respond = do- let mbCookieHeaders = lookup "cookie" (requestHeaders request)- mbSessionIdText = fromText =<< lookup "session" =<< fmap parseCookiesText mbCookieHeaders- mbSessionId = fmap SessionId mbSessionIdText+ route Proxy context subserver = WithRequest $ \request ->+ route (Proxy :: Proxy sublayout) context (addCapture subserver $ do+ let mbCookieHeaders = lookup "cookie" (requestHeaders request)+ mbSessionIdText = lookup "session" =<< fmap parseCookiesText mbCookieHeaders - case mbSessionId of- Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""- Just sId -> route (Proxy :: Proxy sublayout) (subserver sId) request respond+ pure $ case mbSessionIdText of+ Nothing -> FailFatal err401+ Just sessionIdText -> case parseQueryParam sessionIdText of+ Left _ -> FailFatal err401+ Right sId -> Route $ SessionId sId+ ) instance ToByteString SetCookie where