diff --git a/avers-server.cabal b/avers-server.cabal --- a/avers-server.cabal +++ b/avers-server.cabal @@ -1,55 +1,55 @@ -name: avers-server -version: 0.0.5 -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 +name: avers-server +version: 0.0.17.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2016 Tomas Carnecky +maintainer: tomas.carnecky@gmail.com +homepage: http://github.com/wereHamster/avers-server +synopsis: Server implementation of the Avers API +description: + See README.md +category: Avers +author: Tomas Carnecky source-repository head - type: git - location: https://github.com/wereHamster/avers-server + 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 + exposed-modules: + Avers.Server + build-depends: + base >=4.7 && <5, + aeson >=1.0.2.0 && <1.1, + avers -any, + avers-api -any, + base64-bytestring >=1.0.0.1 && <1.1, + bytestring >=0.10.8.1 && <0.11, + bytestring-conversion >=0.3.1 && <0.4, + containers >=0.5.7.1 && <0.6, + cookie >=0.4.2.1 && <0.5, + cryptonite ==0.20.*, + either >=4.4.1.1 && <4.5, + http-types >=0.9.1 && <0.10, + memory ==0.13.*, + mtl >=2.2.1 && <2.3, + resource-pool >=0.2.3.2 && <0.3, + rethinkdb-client-driver >=0.0.23 && <0.1, + servant >=0.9.0.1 && <0.10, + servant-server >=0.9.0.1 && <0.10, + stm >=2.4.4.1 && <2.5, + text >=1.2.2.1 && <1.3, + time >=1.6.0.1 && <1.7, + transformers >=0.5.2.0 && <0.6, + wai >=3.2.1.1 && <3.3, + wai-websockets >=3.0.1.1 && <3.1, + websockets >=0.9.7.0 && <0.10 + default-language: Haskell2010 + hs-source-dirs: src + other-modules: + Avers.Server.Authorization + Avers.Server.Instances + ghc-options: -Wall - build-depends: - base >= 4.7 && < 5 - , aeson - , avers - , avers-api - , base64-bytestring - , bytestring - , bytestring-conversion - , containers - , cookie - , cryptohash - , either - , http-types - , mtl - , resource-pool - , rethinkdb-client-driver - , servant - , servant-server - , stm - , text - , time - , transformers - , wai - , wai-websockets - , websockets diff --git a/src/Avers/Server.hs b/src/Avers/Server.hs --- a/src/Avers/Server.hs +++ b/src/Avers/Server.hs @@ -9,7 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} module Avers.Server - ( serveAversCoreAPI, serveAversSessionAPI + ( serveAversAPI , credentialsObjId @@ -24,40 +24,29 @@ import Control.Concurrent.STM 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 qualified Data.ByteString.Base64 as BS64 import qualified Data.Set as S import Data.Monoid --- import Data.Proxy --- import Data.Maybe import Data.Time import Data.Aeson (ToJSON, encode, decode) --- import Data.Aeson.TH (defaultOptions) -import Crypto.Hash.SHA256 (hashlazy) +import Data.ByteArray.Encoding (Base(Base64), convertToBase) +import Crypto.Hash (Digest, SHA3_256, hashlazy) import Servant.API hiding (Patch) 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 @@ -113,15 +102,15 @@ cacheableResponse :: (ToJSON a) => Maybe Text -> a -> ExceptT ServantErr IO (Cacheable a) cacheableResponse mbValidationToken a = do - let etag = T.decodeUtf8 $ BS64.encode $ hashlazy $ encode a + let etag = T.decodeUtf8 $ convertToBase Base64 $ (hashlazy (encode a) :: Digest SHA3_256) 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 = +serveAversAPI :: Handle -> Authorizations -> Server AversAPI +serveAversAPI aversH auth = serveCreateObject :<|> serveLookupObject :<|> servePatchObject @@ -133,11 +122,18 @@ :<|> serveLookupLatestRelease :<|> serveFeed :<|> serveChangeSecret + :<|> serveCreateSession + :<|> serveLookupSession + :<|> serveDeleteSession + :<|> serveUploadBlob + :<|> serveLookupBlob + :<|> serveLookupBlobContent + :<|> serveSignup where ---------------------------------------------------------------------------- - -- CreateObject + serveCreateObject :: Server CreateObject serveCreateObject cred body = do let objType = cobType body @@ -158,7 +154,7 @@ ---------------------------------------------------------------------------- - -- LookupObject + serveLookupObject :: Server LookupObject serveLookupObject objId cred validationToken = do runAuthorization aversH $ lookupObjectAuthz auth cred objId @@ -179,11 +175,12 @@ , lorContent = snapshotContent } + ---------------------------------------------------------------------------- - -- PatchObject + servePatchObject :: Server PatchObject servePatchObject objId cred body = do - -- runAuthorization aversH $ - -- lookupObjectAuthz auth cred objId + runAuthorization aversH $ + patchObjectAuthz auth cred objId (pobOperations body) authorObjId <- credentialsObjId aversH cred @@ -201,11 +198,18 @@ , porResultingPatches = resultingPatches } - serveDeleteObject _ _ = throwError err500 + ---------------------------------------------------------------------------- + serveDeleteObject :: Server DeleteObject + serveDeleteObject objId cred = do + runAuthorization aversH $ + deleteObjectAuthz auth cred objId + throwError err501 + + ---------------------------------------------------------------------------- - -- LookupPatch + serveLookupPatch :: Server LookupPatch serveLookupPatch objId revId _cred validationToken = do -- TODO: authorization @@ -214,7 +218,7 @@ ---------------------------------------------------------------------------- - -- ObjectChanges + serveObjectChanges :: Server ObjectChanges serveObjectChanges objId _cred req respond = respond $ case websocketsApp WS.defaultConnectionOptions wsApp req of Nothing -> responseLBS status500 [] "Failed" @@ -237,14 +241,26 @@ loop connection chan + ---------------------------------------------------------------------------- + serveCreateRelease :: Server CreateRelease + serveCreateRelease _ _ _ = do + throwError err501 - serveCreateRelease _ _ _ = throwError err500 - serveLookupRelease _ _ _ _ = throwError err500 - serveLookupLatestRelease _ _ _ = throwError err500 + ---------------------------------------------------------------------------- + serveLookupRelease :: Server LookupRelease + serveLookupRelease _ _ _ _ = do + throwError err501 + ---------------------------------------------------------------------------- - -- Feed + serveLookupLatestRelease :: Server LookupLatestRelease + serveLookupLatestRelease _ _ _ = do + throwError err501 + + + ---------------------------------------------------------------------------- + serveFeed :: Server Feed serveFeed _cred req respond = respond $ case websocketsApp WS.defaultConnectionOptions wsApp req of Nothing -> responseLBS status500 [] "This is a WebSocket endpoint" @@ -276,19 +292,13 @@ loop connection subscriptions chan - serveChangeSecret _ _ = throwError err500 - - + ---------------------------------------------------------------------------- + serveChangeSecret :: Server ChangeSecret + serveChangeSecret _ _ = do + throwError err501 -serveAversSessionAPI :: Handle -> Server AversSessionAPI -serveAversSessionAPI aversH = - serveCreateSession - :<|> serveLookupSession - :<|> serveDeleteSession - - where - + ---------------------------------------------------------------------------- sessionCookieName = "session" sessionExpirationTime = 2 * 365 * 24 * 60 * 60 @@ -303,9 +313,7 @@ , setCookieHttpOnly = True } - - ---------------------------------------------------------------------------- - -- CreateSession + serveCreateSession :: Server CreateSession serveCreateSession body = do -- Verify the secret, fail if it is invalid. reqAvers aversH $ verifySecret (csbLogin body) (csbSecret body) @@ -326,7 +334,7 @@ ---------------------------------------------------------------------------- - -- LookupSession + serveLookupSession :: Server LookupSession serveLookupSession sId = do session <- reqAvers aversH $ lookupSession sId @@ -337,7 +345,7 @@ } ---------------------------------------------------------------------------- - -- DeleteSession + serveDeleteSession :: Server DeleteSession serveDeleteSession sId = do reqAvers aversH $ dropSession sId @@ -345,3 +353,46 @@ { setCookieName = sessionCookieName , setCookieExpires = Just $ UTCTime (ModifiedJulianDay 0) 0 }) () + + + ---------------------------------------------------------------------------- + serveUploadBlob :: Server UploadBlob + serveUploadBlob cred mbContentType (BlobContent body) = do + cType <- case mbContentType of + Nothing -> throwError err400 + Just x -> pure x + + runAuthorization aversH $ + uploadBlobAuthz auth cred cType + + (Blob bId size _) <- reqAvers aversH $ do + Avers.createBlob (LBS.fromStrict body) cType + + pure $ UploadBlobResponse bId size cType + + + ---------------------------------------------------------------------------- + serveLookupBlob :: Server LookupBlob + serveLookupBlob blobId cred = do + runAuthorization aversH $ + lookupBlobAuthz auth cred blobId + + (Blob _ size cType) <- reqAvers aversH $ do + Avers.lookupBlob blobId + + pure $ LookupBlobResponse blobId size cType + + + ---------------------------------------------------------------------------- + serveLookupBlobContent :: Server LookupBlobContent + serveLookupBlobContent blobId cred = do + runAuthorization aversH $ + lookupBlobContentAuthz auth cred blobId + + throwError err501 + + + ---------------------------------------------------------------------------- + serveSignup :: Server Signup + serveSignup _body = do + throwError err501 diff --git a/src/Avers/Server/Authorization.hs b/src/Avers/Server/Authorization.hs --- a/src/Avers/Server/Authorization.hs +++ b/src/Avers/Server/Authorization.hs @@ -7,6 +7,9 @@ , trace , sufficient , requisite + + , sessionCreatedObject + , sessionIsObject ) where @@ -30,13 +33,38 @@ data Authorizations = Authorizations { createObjectAuthz :: Credentials -> Text -> Authz , lookupObjectAuthz :: Credentials -> ObjId -> Authz + , patchObjectAuthz :: Credentials -> ObjId -> [Operation] -> Authz + , deleteObjectAuthz :: Credentials -> ObjId -> Authz + , uploadBlobAuthz :: Credentials -> Text -> Authz + , lookupBlobAuthz :: Credentials -> BlobId -> Authz + , lookupBlobContentAuthz :: Credentials -> BlobId -> Authz } defaultAuthorizations :: Authorizations defaultAuthorizations = Authorizations { createObjectAuthz = \_ _ -> [pure AllowR] - , lookupObjectAuthz = \_ _ -> [pure AllowR] + , lookupObjectAuthz = \cred objId -> + [ sufficient $ do + session <- case cred of + SessionIdCredential sId -> lookupSession sId + sessionCreatedObject session objId + ] + , patchObjectAuthz = \cred objId _ -> + [ sufficient $ do + session <- case cred of + SessionIdCredential sId -> lookupSession sId + sessionCreatedObject session objId + ] + , deleteObjectAuthz = \cred objId -> + [ sufficient $ do + session <- case cred of + SessionIdCredential sId -> lookupSession sId + sessionCreatedObject session objId + ] + , uploadBlobAuthz = \_ _ -> [pure AllowR] + , lookupBlobAuthz = \_ _ -> [pure AllowR] + , lookupBlobContentAuthz = \_ _ -> [pure AllowR] } @@ -104,3 +132,21 @@ requisite m = do res <- m pure $ if res then ContinueR else RejectR + + + +------------------------------------------------------------------------------ +-- Authorization modules +------------------------------------------------------------------------------ + +-- | True if the session created the given object. +sessionCreatedObject :: Session -> ObjId -> Avers Bool +sessionCreatedObject session objId = do + obj <- Avers.lookupObject objId + return $ objectCreatedBy obj == sessionObjId session + +-- | True if the session is the given object. In most cases, a session has full +-- access to the object against which it was created. +sessionIsObject :: Session -> ObjId -> Avers Bool +sessionIsObject session objId = do + return $ sessionObjId session == objId diff --git a/src/Avers/Server/Instances.hs b/src/Avers/Server/Instances.hs --- a/src/Avers/Server/Instances.hs +++ b/src/Avers/Server/Instances.hs @@ -15,6 +15,7 @@ import Data.Proxy import Data.ByteString.Conversion +import qualified Data.Text.Encoding as T import Avers import Avers.API @@ -68,5 +69,6 @@ Right sId -> pure $ SessionId sId -instance ToByteString SetCookie where - builder = renderSetCookie + +instance ToHttpApiData SetCookie where + toUrlPiece = T.decodeUtf8 . toByteString' . renderSetCookie