diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Hirotomo Moriwaki + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apiary-session.cabal b/apiary-session.cabal new file mode 100644 --- /dev/null +++ b/apiary-session.cabal @@ -0,0 +1,31 @@ +name: apiary-session +version: 1.2.0 +synopsis: session support for apiary web framework. +description: +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/apiary +Bug-reports: https://github.com/philopon/apiary/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Web +build-type: Simple +stability: experimental +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Web.Apiary.Session + Web.Apiary.Session.Internal + other-modules: + build-depends: base >=4.6 && <4.8 + , apiary >=1.2 && <1.3 + , wai >=3.0 && <3.1 + hs-source-dirs: src + ghc-options: -O2 -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/philopon/apiary.git diff --git a/src/Web/Apiary/Session.hs b/src/Web/Apiary/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Session.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} + +module Web.Apiary.Session + ( Session + , getSession, setSession, deleteSession + , session, session' + , Proxy(Proxy) + ) where + +import Control.Monad(mzero) + +import Control.Monad.Apiary(ApiaryT) +import Control.Monad.Apiary.Action(ActionT, getParams) +import Control.Monad.Apiary.Filter(focus, Doc(DocPrecondition)) + +import Web.Apiary.Session.Internal + (Session(Session), backendGet, backendSet, backendDelete) + +import Data.Apiary.Extension(Has, getExt) +import Data.Apiary.Compat(Proxy(Proxy), KnownSymbol) +import qualified Data.Apiary.Dict as Dict + +-- | get session provided type. +getSession :: (Has (Session sess m) exts, Monad m) => proxy sess -> ActionT exts prms m (Maybe sess) +getSession _ = do + Session b <- getExt Proxy + backendGet b + +-- | set session provided type. +setSession :: (Has (Session sess m) exts, Monad m) => proxy sess -> sess -> ActionT exts prms m () +setSession _ v = do + Session b <- getExt Proxy + backendSet b v + +-- | delete session provided type. +deleteSession :: forall proxy exts prms m sess. (Has (Session sess m) exts, Monad m) + => proxy sess -> ActionT exts prms m () +deleteSession _ = do + Session b <- getExt (Proxy :: Proxy (Session sess m)) + backendDelete b + +-- | filter by has session or not. +session' :: (Has (Session sess actM) exts, KnownSymbol key, Monad actM, Dict.NotMember key kvs) + => kProxy key -> sProxy sess + -> ApiaryT exts (key Dict.:= sess ': kvs) actM m () + -> ApiaryT exts kvs actM m () +session' ky p = focus (DocPrecondition "session cookie required.") $ do + dict <- getParams + getSession p >>= \case + Nothing -> mzero + Just s -> return $ Dict.insert ky s dict + +-- | filter by has session or not. use \"session\" dict key. +-- +-- @ +-- session = session' (Proxy :: Proxy "session") +-- @ +session :: (Has (Session sess actM) exts, Monad actM, Dict.NotMember "session" kvs) + => proxy sess + -> ApiaryT exts ("session" Dict.:= sess ': kvs) actM m () + -> ApiaryT exts kvs actM m () +session = session' (Proxy :: Proxy "session") diff --git a/src/Web/Apiary/Session/Internal.hs b/src/Web/Apiary/Session/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Session/Internal.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Rank2Types #-} + +module Web.Apiary.Session.Internal + ( Session(..) + , SessionBackend(..) + ) where + +import Control.Monad.Apiary.Action(ActionT) +import qualified Network.Wai as Wai +import Data.Apiary.Extension + (Extension(extMiddleware, extMiddleware'), Middleware') + +data Session sess m = forall backend. SessionBackend backend sess m => Session + { sessionBackend :: backend } + +instance Extension (Session sess m) where + extMiddleware (Session back) = backendMiddleware back + extMiddleware' (Session back) = backendMiddleware' back + +class Monad m => SessionBackend backend sess m | backend -> sess, backend -> m where + backendMiddleware :: backend -> Wai.Middleware + backendMiddleware _ = id + {-# INLINE backendMiddleware #-} + + backendMiddleware' :: backend -> Middleware' + backendMiddleware' _ = id + {-# INLINE backendMiddleware' #-} + + genBackendModify :: backend + -> (Maybe sess -> ActionT exts prms m (Maybe sess, a)) + -> ActionT exts prms m a + + backendGet :: backend -> ActionT exts prms m (Maybe sess) + backendGet b = genBackendModify b (\s -> return (s, s)) + + backendSet :: backend -> sess -> ActionT exts prms m () + backendSet b s = genBackendModify b (\_ -> return (Just s, ())) + + backendDelete :: backend -> ActionT exts prms m () + backendDelete b = genBackendModify b (\_ -> return (Nothing, ()))