avers-server (empty) → 0.0.1
raw patch · 6 files changed
+542/−0 lines, 6 filesdep +aesondep +aversdep +avers-apisetup-changed
Dependencies added: aeson, avers, avers-api, base, bytestring, bytestring-conversion, cookie, either, http-types, mtl, resource-pool, rethinkdb-client-driver, servant, servant-server, text, time, transformers, wai, wai-websockets, websockets
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- avers-server.cabal +51/−0
- src/Avers/Server.hs +297/−0
- src/Avers/Server/Authorization.hs +106/−0
- src/Avers/Server/Instances.hs +65/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Tomas Carnecky++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ avers-server.cabal view
@@ -0,0 +1,51 @@+name: avers-server+version: 0.0.1+synopsis: Server implementation of the Avers API+description: See README.md+homepage: http://github.com/wereHamster/avers-server+license: MIT+license-file: LICENSE+author: Tomas Carnecky+maintainer: tomas.carnecky@gmail.com+copyright: 2016 Tomas Carnecky+category: Avers+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/wereHamster/avers-server++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall++ exposed-modules:+ Avers.Server++ other-modules:+ Avers.Server.Authorization+ , Avers.Server.Instances++ build-depends:+ base >= 4.7 && < 5+ , aeson+ , avers+ , avers-api+ , bytestring+ , bytestring-conversion+ , cookie+ , either+ , http-types+ , mtl+ , resource-pool+ , rethinkdb-client-driver+ , servant+ , servant-server+ , text+ , time+ , transformers+ , wai+ , wai-websockets+ , websockets
+ src/Avers/Server.hs view
@@ -0,0 +1,297 @@+{-# 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+ }) ()
+ src/Avers/Server/Authorization.hs view
@@ -0,0 +1,106 @@+module Avers.Server.Authorization+ ( Authorizations(..), Authz, AuthzR(..)+ , defaultAuthorizations++ , runAuthorization++ , trace+ , sufficient+ , requisite+ ) where+++import Control.Monad.IO.Class+import Control.Monad.Trans.Either++import Data.Text (Text)++import Avers+import Avers.API++import Servant.Server+++++--------------------------------------------------------------------------------+-- | Defines all the authorization points which are used in the server. For+-- each you can supply your own logic. The default is to allow everything.++data Authorizations = Authorizations+ { createObjectAuthz :: Credentials -> Text -> Authz+ , lookupObjectAuthz :: Credentials -> ObjId -> Authz+ }+++defaultAuthorizations :: Authorizations+defaultAuthorizations = Authorizations+ { createObjectAuthz = \_ _ -> [pure AllowR]+ , lookupObjectAuthz = \_ _ -> [pure AllowR]+ }++++--------------------------------------------------------------------------------+-- | Authorization logic is implemented as a list of 'Avers' actions, each of+-- which we call a @module@ and returns a result ('AuthzR'), which determines+-- what happens next.++type Authz = [Avers AuthzR]++++--------------------------------------------------------------------------------+-- | The result of a single module is either 'ContinueR', which means we+-- continue executing following modules, 'AllowR' which means that the+-- action is allowed and any following modules are skipped, or 'RejcetR' which+-- means that the action is rejected and following modules are skipped as well.++data AuthzR = ContinueR | AllowR | RejectR+++++--------------------------------------------------------------------------------+-- | Run the authorization logic inside of the Servant monad.++runAuthorization :: Handle -> Authz -> EitherT ServantErr IO ()+runAuthorization _ [] = pure ()+runAuthorization aversH (x:xs) = do+ res <- liftIO $ evalAvers aversH x+ case res of+ Left _ -> left $ err500+ Right r -> case r of+ ContinueR -> runAuthorization aversH xs+ AllowR -> pure ()+ RejectR -> left $ err401+++++--------------------------------------------------------------------------------+-- | This doesn't change the result, but allows you to run arbitrary 'Avers'+-- actions. This is useful for debugging.++trace :: Avers () -> Avers AuthzR+trace m = m >> pure ContinueR+++--------------------------------------------------------------------------------+-- | If the given 'Avers' action returns 'True', it is sufficient to pass+-- the authorization check.++sufficient :: Avers Bool -> Avers AuthzR+sufficient m = do+ res <- m+ pure $ if res then AllowR else ContinueR+++--------------------------------------------------------------------------------+-- | The given 'Avers' action must return 'True' for this authorization check+-- to pass.++requisite :: Avers Bool -> Avers AuthzR+requisite m = do+ res <- m+ pure $ if res then ContinueR else RejectR
+ src/Avers/Server/Instances.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Avers.Server.Instances where+++import Data.Proxy+import Data.ByteString.Conversion++import Avers+import Avers.API++import Servant.API+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++ 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++ case mbCredentials of+ Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""+ Just cred -> route (Proxy :: Proxy sublayout) (subserver cred) request respond++++instance (HasServer sublayout) => HasServer (SessionId :> sublayout) 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++ case mbSessionId of+ Nothing -> respond $ RR $ Right $ responseLBS status401 [] ""+ Just sId -> route (Proxy :: Proxy sublayout) (subserver sId) request respond+++instance ToByteString SetCookie where+ builder = renderSetCookie