avers-server 0.0.5 → 0.0.17.0

raw patch · 4 files changed

+197/−98 lines, 4 filesdep +cryptonitedep +memorydep −cryptohashdep ~aesondep ~base64-bytestringdep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: cryptonite, memory

Dependencies removed: cryptohash

Dependency ranges changed: aeson, base64-bytestring, bytestring, bytestring-conversion, containers, cookie, either, http-types, mtl, resource-pool, rethinkdb-client-driver, servant, servant-server, stm, text, time, transformers, wai, wai-websockets, websockets

API changes (from Hackage documentation)

Files

• avers-server.cabal +50/−50
• src/Avers/Server.hs +96/−45
• src/Avers/Server/Authorization.hs +47/−1
• src/Avers/Server/Instances.hs +4/−2

@@ -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

@@ -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

@@ -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

@@ -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