initial commit

README.md

@@ -0,0 +1,17 @@
+#servant-auth-cookie
+
+##Description
+
+Authentication via encrypted client-side cookies, inspired by
+[client-session](https://hackage.haskell.org/package/clientsession)
+library by Michael Snoyman and based on ideas of the paper
+["A Secure Cookie Protocol"](http://www.cse.msu.edu/~alexliu/publications/Cookie/cookie.pdf)
+by Alex Liu et al.
+
+
+##Warning
+This library is under development.
+
+At the moment here is already working example of cookie
+authentication, but further research and testing should be done.
+Some underlying mechanisms will be changed as well as the module API.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

default.nix

@@ -0,0 +1,22 @@
+{ mkDerivation, base, base64-bytestring, blaze-html, blaze-markup
+, bytestring, cereal, cookie, cryptonite, http-media, http-types
+, memory, servant, servant-server, stdenv, text, time, transformers
+, wai, warp
+}:
+mkDerivation {
+  pname = "servant-auth-cookie";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    base base64-bytestring bytestring cereal cookie cryptonite
+    http-types memory servant servant-server time transformers wai
+  ];
+  executableHaskellDepends = [
+    base blaze-html blaze-markup bytestring cereal http-media servant
+    servant-server text wai warp
+  ];
+  description = "Authentication via encrypted cookies";
+  license = stdenv.lib.licenses.gpl3;
+}

example/Main.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+
+import Control.Monad (when)
+
+import Data.Maybe (fromJust, isNothing)
+import Data.Serialize (Serialize)
+import qualified Data.Text as T (unpack)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (toStrict, fromStrict)
+
+import Servant (
+    Proxy(..), Server, (:>), (:<|>)(..)
+  , Header, Headers, addHeader
+  , Get, Post, ReqBody, FormUrlEncoded, FromFormUrlEncoded(..))
+
+import Servant.Server (
+    Context ((:.), EmptyContext)
+  , serveWithContext)
+
+import Servant.API.Experimental.Auth    (AuthProtect)
+import Servant.API.ContentTypes         (Accept(..), MimeRender(..))
+import Servant.Server.Experimental.Auth (AuthHandler)
+import Servant.Server.Experimental.Auth.Cookie
+
+import Network.Wai              (Application, Request)
+import Network.Wai.Handler.Warp (run)
+
+import GHC.Generics
+
+import Network.HTTP.Media ((//), (/:))
+
+import Text.Blaze.Html5 ((!))
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+
+
+data HTML
+
+instance Accept HTML where
+   contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+instance MimeRender HTML ByteString where
+   mimeRender _ x = fromStrict $ x
+
+
+data Account = Account Int String String
+  deriving (Show, Eq, Generic)
+
+instance Serialize Account
+
+type instance AuthCookieData = Account
+
+
+data LoginForm = LoginForm {
+  username :: String  
+, password :: String
+} deriving (Eq, Show)
+
+instance FromFormUrlEncoded LoginForm where
+  fromFormUrlEncoded d = do
+    let username' = lookup "username" d
+    when (isNothing username') $ Left "username field is missing"
+
+    let password' = lookup "password" d
+    when (isNothing username') $ Left "password field is missing"
+
+    Right $ LoginForm {
+        username = T.unpack . fromJust $ username'
+      , password = T.unpack . fromJust $ password'
+      }
+
+
+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 _ _ [] = Nothing
+userLookup username' password' ((Account uid username'' password''):as) =
+  case (username', password') == (username'', password'') of
+    True  -> Just uid
+    False -> userLookup username' password' as
+
+
+type ExampleAPI =
+       Get '[HTML] ByteString
+  :<|> ReqBody '[FormUrlEncoded] LoginForm
+       :> Post '[HTML] (Headers '[Header "set-cookie" ByteString] ByteString)
+  :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] ByteString
+
+
+server :: Server ExampleAPI
+server = servePublicPage :<|> serveLogin :<|> servePrivatePage where
+
+  servePrivatePage (Account uid u p) = return $ render (privatePage uid u p)
+
+  servePublicPage = return $ render (publicPage "")
+
+  serveLogin form = case userLookup (username form) (password form) usersDB of
+    Nothing   -> return $ addHeader "" (render $ publicPage "Incorrect username/password")
+    Just uid' -> addSession 
+                   authSettings
+                   (Account uid' (username form) (password form))
+                   (render $ publicPage "You are logged in")
+
+  render = toStrict . renderHtml
+
+
+authSettings :: Settings
+authSettings = defaultSettings {
+    cookieFlags = []
+  , hideReason = False
+  }
+
+app :: Application
+app = serveWithContext
+  (Proxy :: Proxy ExampleAPI)
+  ((defaultAuthHandler authSettings :: AuthHandler Request Account) :. EmptyContext)
+  server
+
+main :: IO ()
+main = run 8080 app 
+
+
+pageMenu :: H.Html
+pageMenu = do
+  H.a ! A.href "/"        $ "public"
+  _ <- " "
+  H.a ! A.href "/private" $ "private"
+  H.hr
+
+publicPage :: String -> H.Html
+publicPage message = H.docTypeHtml $ do
+  H.head $ do
+    H.title "public page"
+  H.body $ do
+    pageMenu
+    H.form ! A.method "post" ! A.action "/" $ do
+      H.input ! A.type_ "text"     ! A.name "username" >> H.br
+      H.input ! A.type_ "password" ! A.name "password" >> H.br
+      H.input ! A.type_ "submit"
+    when (length message > 0) $ H.p (H.toHtml message)
+
+privatePage :: Int -> String -> String -> H.Html
+privatePage uid username' password' = H.docTypeHtml $ do
+  H.head $ do
+    H.title "private page"
+  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'

servant-auth-cookie.cabal

@@ -0,0 +1,57 @@
+name:                servant-auth-cookie
+version:             0.1.0.0
+synopsis:            Authentication via encrypted cookies
+description:         Authentication via encrypted client-side cookies,
+                     inspired by client-session library by Michael Snoyman and based on
+                     ideas of the paper "A Secure Cookie Protocol" by Alex Liu et al.
+license:             GPL-3
+license-file:        LICENSE
+author:              Al Zohali
+maintainer:          Al Zohali <zohl@fmap.me>
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+
+source-repository head
+  type:     git
+  location: https://github.com/zohl/servant-auth-cookie.git
+
+
+library
+  exposed-modules:     
+    Servant.Server.Experimental.Auth.Cookie
+  build-depends: base >=4.8 && <4.9
+               , base64-bytestring
+               , bytestring
+               , cereal
+               , cookie
+               , cryptonite
+               , http-types
+               , memory
+               , servant
+               , servant-server
+               , time >=1.5 && <1.6
+               , transformers
+               , wai
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+
+executable example
+  main-is:             Main.hs
+  other-extensions:    DataKinds, TypeFamilies, DeriveGeneric, TypeOperators
+  build-depends: base >=4.8 && <4.9
+               , blaze-html
+               , blaze-markup
+               , bytestring
+               , cereal
+               , http-media
+               , servant
+               , servant-auth-cookie
+               , servant-server
+               , text
+               , wai
+               , warp
+  hs-source-dirs:      example
+  default-language:    Haskell2010

shell.nix

@@ -0,0 +1,15 @@
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
+
+let
+  inherit (nixpkgs) pkgs;
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  haskellPackages_ = haskellPackages.override { };
+
+  drv = haskellPackages_.callPackage ./default.nix {};
+
+in 
+  if pkgs.lib.inNixShell then drv.env else drv