diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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" diff --git a/servant-auth-cookie.cabal b/servant-auth-cookie.cabal --- a/servant-auth-cookie.cabal +++ b/servant-auth-cookie.cabal @@ -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 diff --git a/src/Servant/Server/Experimental/Auth/Cookie.hs b/src/Servant/Server/Experimental/Auth/Cookie.hs --- a/src/Servant/Server/Experimental/Auth/Cookie.hs +++ b/src/Servant/Server/Experimental/Auth/Cookie.hs @@ -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