servant-auth-cookie 0.4.2.1 → 0.4.3
raw patch · 3 files changed
+101/−228 lines, 3 filesdep ~blaze-htmldep ~exceptionsnew-component:exe:example
Dependency ranges changed: blaze-html, exceptions
Files
- example/Main.hs +2/−163
- servant-auth-cookie.cabal +50/−37
- src/Servant/Server/Experimental/Auth/Cookie.hs +49/−28
example/Main.hs view
@@ -8,177 +8,16 @@ {-# LANGUAGE TypeOperators #-} module Main (main) where-+import AuthAPI (app, authSettings) import Prelude () import Prelude.Compat--import Control.Monad import Crypto.Random (drgNew)-import Data.Default-import Data.List (find)-import Data.Serialize (Serialize)-import GHC.Generics-import Network.Wai (Application, Request) import Network.Wai.Handler.Warp (run)-#if MIN_VERSION_servant (0,9,0)-import Web.FormUrlEncoded (FromForm(..), lookupUnique)-#else-import Servant (FromFormUrlEncoded(..))-#endif-import Servant ((:<|>)(..), (:>), ReqBody, FormUrlEncoded)-import Servant (Post, Headers, Header, AuthProtect, Get, Server, Proxy)-import Servant (addHeader, serveWithContext, Proxy(..), Context(..))-import Servant.HTML.Blaze-import Servant.Server.Experimental.Auth (AuthHandler) import Servant.Server.Experimental.Auth.Cookie-import Text.Blaze.Html5 ((!), Markup)-import System.Exit (exitSuccess)-import System.Environment (getArgs)-import qualified Data.Text as T-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A -data Account = Account- { accUid :: Int- , _accUsername :: String- , _accPassword :: String- } deriving (Show, Eq, Generic)--instance Serialize Account--type instance AuthCookieData = Account--data LoginForm = LoginForm- { lfUsername :: String- , lfPassword :: String- } deriving (Eq, Show)--#if MIN_VERSION_servant (0,9,0)-instance FromForm LoginForm where- fromForm f = do- username <- fmap T.unpack $ lookupUnique "username" f- password <- fmap T.unpack $ lookupUnique "password" f- return LoginForm- { lfUsername = username- , lfPassword = password }-#else-instance FromFormUrlEncoded LoginForm where- fromFormUrlEncoded d = do- username <- case lookup "username" d of- Nothing -> Left "username field is missing"- Just x -> return (T.unpack x)- password <- case lookup "password" d of- Nothing -> Left "password field is missing"- Just x -> return (T.unpack x)- return LoginForm- { lfUsername = username- , lfPassword = password }-#endif--usersDB :: [Account]-usersDB =- [ Account 101 "mr_foo" "password1"- , Account 102 "mr_bar" "letmein"- , Account 103 "mr_baz" "baseball" ]--userLookup :: String -> String -> [Account] -> Maybe Int-userLookup username password db = accUid <$> find f db- where f (Account _ u p) = u == username && p == password--type ExampleAPI =- Get '[HTML] Markup- :<|> "login" :> Get '[HTML] Markup- :<|> "login" :> ReqBody '[FormUrlEncoded] LoginForm- :> Post '[HTML] (Headers '[Header "set-cookie" EncryptedSession] Markup)- :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] Markup--server :: AuthCookieSettings -> RandomSource -> ServerKey -> Server ExampleAPI-server settings rs sk = serveHome- :<|> serveLogin- :<|> serveLoginPost- :<|> servePrivate where-- serveHome = return homePage- serveLogin = return (loginPage True)-- serveLoginPost LoginForm {..} =- case userLookup lfUsername lfPassword usersDB of- Nothing -> return $ addHeader emptyEncryptedSession (loginPage False)- Just uid -> addSession- settings -- the settings- rs -- random source- sk -- server key- (Account uid lfUsername lfPassword)- (redirectPage "/private")-- servePrivate (Account uid u p) = return (privatePage uid u p)--app :: AuthCookieSettings -> RandomSource -> ServerKey -> Application-app settings rs sk = serveWithContext- (Proxy :: Proxy ExampleAPI)- ((defaultAuthHandler settings sk :: AuthHandler Request Account) :. EmptyContext)- (server settings rs sk)- main :: IO () main = do- args <- getArgs- when (args /= ["run"]) $ do- putStrLn "Use './example run' to run an example"- exitSuccess rs <- mkRandomSource drgNew 1000 sk <- mkServerKey 16 Nothing- run 8080 (app def rs sk)--pageMenu :: Markup-pageMenu = do- H.a ! A.href "/" $ "home"- void " "- H.a ! A.href "/login" $ "login"- void " "- H.a ! A.href "/private" $ "private"- H.hr--homePage :: Markup-homePage = H.docTypeHtml $ do- H.head (H.title "home")- H.body $ do- pageMenu- H.p "This is an example of using servant-auth-cookie library."- H.p "Use login page to get access to the private page."--loginPage :: Bool -> Markup-loginPage firstTime = H.docTypeHtml $ do- H.head (H.title "login")- H.body $ do- pageMenu- H.form ! A.method "post" ! A.action "/login" $ do- H.table $ do- H.tr $ do- H.td "username:"- H.td (H.input ! A.type_ "text" ! A.name "username")- H.tr $ do- H.td "password:"- H.td (H.input ! A.type_ "password" ! A.name "password")- H.input ! A.type_ "submit"- unless firstTime $- H.p "Incorrect username/password"--privatePage :: Int -> String -> String -> Markup-privatePage uid username' password' = H.docTypeHtml $ do- H.head (H.title "private")- H.body $ do- pageMenu- H.p $ H.b "ID: " >> H.toHtml (show uid)- H.p $ H.b "username: " >> H.toHtml username'- H.p $ H.b "password: " >> H.toHtml password'+ run 8080 (app authSettings rs sk) -redirectPage :: String -> Markup-redirectPage uri = H.docTypeHtml $ do- H.head $ do- H.title "redirecting..."- H.meta ! A.httpEquiv "refresh" ! A.content (H.toValue $ "1; url=" ++ uri)- H.body $ do- H.p "You are being redirected."- H.p $ do- void "If your browser does not refresh the page click "- H.a ! A.href (H.toValue uri) $ "here"
servant-auth-cookie.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-cookie-version: 0.4.2.1+version: 0.4.3 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on@@ -27,6 +27,11 @@ manual: False default: True +flag build-examples+ description: Build example executables.+ default: False++ library exposed-modules: Servant.Server.Experimental.Auth.Cookie@@ -66,42 +71,6 @@ servant < 0.9, bytestring-conversion >= 0.3.1 && <0.4 -test-suite example- type: exitcode-stdio-1.0- main-is: Main.hs- build-depends: base >= 4.7 && < 5.0- , base-compat >= 0.9.1 && <0.10- , blaze-html >= 0.8 && < 0.9- , blaze-markup >= 0.7 && < 0.8- , bytestring- , cereal >= 0.5 && < 0.6- , cryptonite >= 0.14 && <= 0.21- , data-default- , http-media- , mtl >= 2.0 && < 3.0- , servant >= 0.5 && < 0.10- , servant-auth-cookie- , servant-blaze >= 0.5 && < 0.10- , servant-server >= 0.5 && < 0.10- , text- , wai >= 3.0 && < 3.3- , warp >= 3.0 && < 3.3- if flag(dev)- ghc-options: -Wall -Werror- else- ghc-options: -O2 -Wall- hs-source-dirs: example- default-language: Haskell2010-- if flag(servant9)- build-depends:- servant >= 0.9,- http-api-data == 0.3.*- else- build-depends:- servant < 0.9,- bytestring-conversion >= 0.3.1 && <0.4- test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -125,6 +94,50 @@ if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* default-language: Haskell2010+++executable example+ main-is: Main.hs+ hs-source-dirs: example++ if flag(build-examples)+ build-depends: base >= 4.7 && < 5.0+ , base-compat >= 0.9.1 && <0.10+ , blaze-html >= 0.8 && <= 0.9.0.1+ , blaze-markup >= 0.7 && < 0.8+ , bytestring+ , cereal >= 0.5 && < 0.6+ , cryptonite >= 0.14 && <= 0.21+ , data-default+ , exceptions+ , http-media+ , mtl >= 2.0 && < 3.0+ , servant >= 0.5 && < 0.10+ , servant-auth-cookie+ , servant-blaze >= 0.5 && < 0.10+ , servant-server >= 0.5 && < 0.10+ , text+ , transformers >= 0.4 && < 0.6+ , wai >= 3.0 && < 3.3+ , warp >= 3.0 && < 3.3+ if flag(servant9)+ build-depends:+ servant >= 0.9,+ http-api-data == 0.3.*+ else+ build-depends:+ servant < 0.9,+ bytestring-conversion >= 0.3.1 && <0.4+ else+ buildable: False++ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010++ benchmark bench type: exitcode-stdio-1.0
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -62,6 +62,7 @@ ) where import Blaze.ByteString.Builder (toByteString)+import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Catch (MonadThrow (..), Exception) import Control.Monad.Except@@ -75,7 +76,7 @@ import Data.ByteString (ByteString) import Data.Default import Data.IORef-import Data.Maybe (fromMaybe, isNothing)+import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.Serialize@@ -213,54 +214,74 @@ ---------------------------------------------------------------------------- -- Server key +-- | A mutable state of ServerKey.+data ServerKeyState = ServerKeyState+ { sksBytes :: ByteString+ -- ^ Current value of the key+ , sksExpirationTime :: UTCTime+ -- ^ When the key is expires+ }+ -- | A wrapper of self-resetting 'ByteString' of random symbols suitable for -- concurrent usage.-data ServerKey =- ServerKey Int (Maybe NominalDiffTime) (IORef (ByteString, UTCTime))+data ServerKey = ServerKey+ { skSize :: Int+ -- ^ Size of the key (in bytes)+ , skMaxAge :: Maybe NominalDiffTime+ -- ^ Expiration time ('Nothing' is enternity)+ , skState :: IORef ServerKeyState+ -- ^ Mutable state of the key+ } -- | Constructor for 'ServerKey' value. mkServerKey :: MonadIO m => Int -- ^ Size of the server key -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity) -> m ServerKey -- ^ New 'ServerKey'-mkServerKey size maxAge =- ServerKey size maxAge `liftM` liftIO (mkServerKeyState size maxAge >>= newIORef)+mkServerKey skSize skMaxAge = liftIO $ do+ skState <- mkServerKeyState skSize skMaxAge >>= newIORef+ return ServerKey {..} -- | Constructor for 'ServerKey' value using predefined key. mkServerKeyFromBytes :: MonadIO m => ByteString -- ^ Predefined key -> m ServerKey -- ^ New 'ServerKey'-mkServerKeyFromBytes bytes =- ServerKey (BS.length bytes) Nothing `liftM` liftIO (newIORef (bytes, timeOrigin))- where- -- we don't care about the time as the key never expires- timeOrigin = UTCTime (toEnum 0) 0+mkServerKeyFromBytes bytes = liftIO $ do+ let skSize = BS.length bytes+ let skMaxAge = Nothing+ skState <- newIORef ServerKeyState+ { sksBytes = bytes+ , sksExpirationTime = UTCTime (toEnum 0) 0+ -- we don't care about the time as the key never expires+ }+ return ServerKey {..} -- | Extract value from 'ServerKey'. getServerKey :: MonadIO m => ServerKey -- ^ The 'ServerKey' -> m ByteString -- ^ Its random symbol-getServerKey (ServerKey size maxAge ref) = do- currentTime <- liftIO getCurrentTime- (key', expirationTime') <- mkServerKeyState size maxAge- liftIO . atomicModifyIORef' ref $ \(key, expirationTime) ->- let expired =- if isNothing maxAge- then False- else currentTime > expirationTime- in if expired- then ((key', expirationTime'), key')- else ((key, expirationTime), key)+getServerKey ServerKey {..} = liftIO $ maybe+ (sksBytes <$> readIORef skState)+ (\_ -> do+ currentTime <- getCurrentTime+ state <- readIORef skState+ case (currentTime > sksExpirationTime state) of+ False -> return $ sksBytes state+ True -> do+ state' <- mkServerKeyState skSize skMaxAge+ atomicModifyIORef' skState $ \state'' -> id &&& sksBytes $+ if (sksBytes state == sksBytes state'') then state' else state'')+ skMaxAge -- | An initializer of 'ServerKey' state.-mkServerKeyState :: MonadIO m- => Int -- ^ Size of the server key+mkServerKeyState+ :: Int -- ^ Size of the server key -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity)- -> m (ByteString, UTCTime)-mkServerKeyState size maxAge = liftIO $ do- key <- fst . randomBytesGenerate size <$> drgNew- time <- addUTCTime (fromMaybe 0 maxAge) <$> getCurrentTime- return (key, time)+ -> IO ServerKeyState+mkServerKeyState skSize skMaxAge = do+ sksBytes <- fst . randomBytesGenerate skSize <$> drgNew+ sksExpirationTime <- addUTCTime (fromMaybe 0 skMaxAge) <$> getCurrentTime+ return ServerKeyState {..} ---------------------------------------------------------------------------- -- Settings