packages feed

snaplet-sqlite-simple-jwt-auth (empty) → 0.1.0.0

raw patch · 8 files changed

+583/−0 lines, 8 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, bcrypt, bytestring, clientsession, containers, directory, either, errors, jwt, lens, mtl, snap, snap-core, snaplet-sqlite-simple, sqlite-simple, text, time, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Janne Hellsten (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snaplet-sqlite-simple-jwt-auth.cabal view
@@ -0,0 +1,56 @@+name:                snaplet-sqlite-simple-jwt-auth+version:             0.1.0.0+synopsis:            Snaplet for JWT authentication with snaplet-sqlite-simple+description:+    JWT authentication snaplet for snaplet-sqlite-simple.+    .+    Very much a work-in-progress, use at your own risk.+    .+    Main documentation: <docs/Snap-Snaplet-SqliteSimple-JwtAuth Snap.Snaplet.SqliteSimple.JwtAuth>+    .+    For more info, browse to <http://github.com/nurpax/snaplet-sqlite-simple-jwt-auth> for examples & more information.+homepage:            https://github.com/nurpax/snaplet-sqlite-simple-jwt-auth#readme+license:             BSD3+license-file:        LICENSE+author:              Janne Hellsten+maintainer:          jjhellst@gmail.com+copyright:           2016 Janne Hellsten+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Snap.Snaplet.SqliteSimple.JwtAuth+                       Snap.Snaplet.SqliteSimple.JwtAuth.JwtAuth+                       Snap.Snaplet.SqliteSimple.JwtAuth.Db+                       Snap.Snaplet.SqliteSimple.JwtAuth.Util+                       Snap.Snaplet.SqliteSimple.JwtAuth.Types+  ghc-options:         -Wall+  build-depends:+    aeson,+    attoparsec,+    base                  >= 4      && < 5,+    bcrypt                >= 0.0.10,+    bytestring            >= 0.9.1  && < 0.11,+    clientsession,+    containers,+    directory,+    jwt,+    lens,+    mtl                   >= 2 && < 3,+    snap                  >= 1.0,+    snap-core             >= 1.0,+    snaplet-sqlite-simple >= 1.0,+    sqlite-simple         >= 0.4.9.0,+    text                  >= 1.2,+    time                  >= 1.5,+    either                >= 3.1,+    errors                >= 2.1.2,+    unordered-containers+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/nurpax/snaplet-sqlite-simple-jwt-auth+
+ src/Snap/Snaplet/SqliteSimple/JwtAuth.hs view
@@ -0,0 +1,56 @@+------------------------------------------------------------------------------+-- Module:      Snap.Snaplet.SqliteSimple.JwtAuth+------------------------------------------------------------------------------++module Snap.Snaplet.SqliteSimple.JwtAuth (+  -- * Introduction+  -- $intro++  -- * Types+    SqliteJwt(..)+  , User(..)+  , AuthFailure(..)+  -- * Initialization+  , sqliteJwtInit+  -- * High-level handlers++  -- | Use these handlers to implement user registration, login and protecting+  -- routes with authentication.+  --+  -- If you need to customize error handling or need a different JSON schema+  -- for communicating between the server and client, you may wish the re-+  -- implement these using the low-level handlers documented later in the+  -- API ref.+  , registerUser+  , loginUser+  , requireAuth+  -- * Lower-level login handlers++  -- | Use these if you need more customized login/register user functionality.+  , createUser+  , login+  -- * Utility functions+  --+  -- | Helper functions for JSON request parameters and JSON responses.+  , jsonResponse+  , writeJSON+  , reqJSON+  ) where++import Snap.Snaplet.SqliteSimple.JwtAuth.Types+import Snap.Snaplet.SqliteSimple.JwtAuth.JwtAuth++-- $intro+-- NOTE: This is still very much a work-in-progress project!+--+-- A snap middleware for implementing JWT-based authentication with user+-- accounts persisted in a SQLite3 database.  It's intended use is to protect+-- server API routes used in single-page web applications (SPA) and mobile+-- applications.+--+-- See the https://github.com/nurpax/snap-reactjs-todo project for a full+-- application using this library.  It implements a todo application as an SPA+-- using React and Redux with a Haskell API server running on Snap and uses+-- this library to implement logins and route authentication.  This+-- <http://nurpax.github.io/posts/2016-11-01-react-redux-haskell-snap.html blog post>+-- has a walk-through of the application's source code.
+ src/Snap/Snaplet/SqliteSimple/JwtAuth/Db.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Snaplet.SqliteSimple.JwtAuth.Db where++import           Control.Concurrent+import           Control.Monad.State+import           Data.ByteString (ByteString)+import           Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Database.SQLite.Simple as S+import           Snap+import           Snap.Snaplet.SqliteSimple++import           Snap.Snaplet.SqliteSimple.JwtAuth.Types++-- Used only internally in this module, shouldn't expose as this contains the+-- hashed password.+data DbUser = DbUser {+    dbuserId         :: Int+  , dbuserLogin      :: T.Text+  , dbuserHashedPass :: ByteString+  } deriving (Eq, Show)++instance FromRow DbUser where+  fromRow = DbUser <$> field <*> field <*> field++jwtAuthTable :: T.Text+jwtAuthTable = "jwt_auth"++versionTable :: T.Text+versionTable = T.concat [jwtAuthTable, "_version"]++userTable :: T.Text+userTable = T.concat [jwtAuthTable, "_user"]++schemaVersion :: S.Connection -> IO Int+schemaVersion conn = do+  versionExists <- tableExists conn versionTable+  if not versionExists+    then return 0+    else do+      [Only v] <- S.query_ conn (qconcat ["SELECT version FROM ", versionTable, " LIMIT 1"]) :: IO [Only Int]+      return v++tableExists :: S.Connection -> T.Text -> IO Bool+tableExists conn tblName = do+  r <- S.query conn "SELECT name FROM sqlite_master WHERE type='table' AND name=?" (Only tblName)+  case r of+    [Only (_ :: String)] -> return True+    _ -> return False++setSchemaVersion :: S.Connection -> Int -> IO ()+setSchemaVersion conn v = do+  let q = S.Query $ T.concat ["UPDATE ", versionTable, " SET version = ?"]+  S.execute conn q (Only v)++upgradeSchema :: Connection -> Int -> IO ()+upgradeSchema conn fromVersion = do+  ver <- schemaVersion conn+  when (ver == fromVersion) (upgrade ver >> setSchemaVersion conn (fromVersion+1))+  where+    upgrade 0 = do+      S.execute_ conn (S.Query $ T.concat ["CREATE TABLE ", versionTable, " (version INTEGER)"])+      S.execute_ conn (S.Query $ T.concat ["INSERT INTO  ", versionTable, " VALUES (1)"])++    upgrade _ = error "unknown version"++createInitialSchema :: S.Connection -> IO ()+createInitialSchema conn = do+  let q = S.Query $ T.concat+          [ "CREATE TABLE ", userTable, " (uid INTEGER PRIMARY KEY,"+          , "login text UNIQUE NOT NULL,"+          , "password text,"+          , "created_on timestamp);"+          ]+  S.execute_ conn q++createTableIfMissing :: MVar S.Connection -> IO ()+createTableIfMissing connMVar =+    withMVar connMVar $ \conn -> do+      authTblExists <- tableExists conn userTable+      unless authTblExists $ createInitialSchema conn+      upgradeSchema conn 0++executeSingle :: (ToRow q) => S.Query -> q -> H b ()+executeSingle q ps = do+  conn <- gets sqliteJwtConn+  liftIO $ withMVar conn $ \c ->+    S.execute c q ps++querySingle :: (ToRow q, FromRow a) => S.Query -> q -> H b (Maybe a)+querySingle q ps = do+  conn <- gets sqliteJwtConn+  liftIO $ withMVar conn $ \c ->+    return . listToMaybe =<< S.query c q ps++qconcat :: [T.Text] -> S.Query+qconcat = S.Query . T.concat++fromDbUser :: DbUser -> User+fromDbUser (DbUser i l _) = User i l++queryUser :: T.Text -> Handler b SqliteJwt (Maybe DbUser)+queryUser login = do+  querySingle (qconcat ["SELECT uid,login,password FROM ", userTable, " WHERE login=?"])+    (Only login)++insertUser :: T.Text -> ByteString -> Handler b SqliteJwt ()+insertUser login hashedPass = do+  let insq = qconcat ["INSERT INTO ", userTable, " (login,password) VALUES (?,?)"]+  executeSingle insq (login,hashedPass)
+ src/Snap/Snaplet/SqliteSimple/JwtAuth/JwtAuth.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-++Minimal proof of concept JWT authentication snaplet using snaplet-sqlite-+simple.++-}++module Snap.Snaplet.SqliteSimple.JwtAuth.JwtAuth (+    SqliteJwt(..)+  , User(..)+  , AuthFailure(..)+  , sqliteJwtInit+  , requireAuth+  , registerUser+  , loginUser+  , createUser+  , login+  , jsonResponse+  , writeJSON+  , reqJSON+  ) where++------------------------------------------------------------------------------+import           Control.Lens hiding ((.=), (??))+import           Control.Monad.Except+import           Control.Monad.State (gets)+import           Control.Error hiding (err)+import qualified Crypto.BCrypt as BC+import           Data.Aeson+import           Data.Aeson.Types (parseEither)+import qualified Data.Attoparsec.ByteString.Char8 as AP+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import           Data.Maybe+import           Data.Map as M+import           Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as LT+import           Snap+import           Snap.Snaplet.SqliteSimple (Sqlite, sqliteConn)+import qualified Web.JWT as JWT++import           Snap.Snaplet.SqliteSimple.JwtAuth.Util+import           Snap.Snaplet.SqliteSimple.JwtAuth.Types+import qualified Snap.Snaplet.SqliteSimple.JwtAuth.Db as Db++bcryptPolicy :: BC.HashingPolicy+bcryptPolicy = BC.fastBcryptHashingPolicy++-------------------------------------------------------------------------+-- | Initializer for the sqlite-simple JwtAuth snaplet.+--+-- If the secret random key 'jwtSigningKeyFname' doesn't exist in the current+-- working directory, a new random key will be generated.  Otherwise the+-- existing key will be loaded as the site signing key.  This key is used to+-- sign the JWTs generated by the login procedure.+--+-- Initialization will automatically setup SQL tables used to store user+-- accounts.  It will also automatically upgrade the SQL schema if necessary.+sqliteJwtInit+  :: String         -- ^ JWT secret signing key filename+  -> Snaplet Sqlite -- ^ The sqlite-simple snaplet+  -> SnapletInit b SqliteJwt+sqliteJwtInit jwtSigningKeyFname db = makeSnaplet "sqlite-simple-jwt" description Nothing $ do+    k <- liftIO $ (JWT.binarySecret <$> getKey jwtSigningKeyFname)+    let conn = sqliteConn $ db ^# snapletValue+    liftIO $ Db.createTableIfMissing conn+    return $ SqliteJwt k conn+  where+    description = "sqlite-simple jwt auth"++-------------------------------------------------------------------------+-- | Create a new user.+createUser+  :: T.Text -- ^ Login name of the user to be created+  -> T.Text -- ^ Password of the new user+  -> Handler b SqliteJwt (Either AuthFailure User)+createUser loginName password = do+  user <- Db.queryUser loginName+  case user of+    Nothing -> do+      hashedPass <- liftIO $ BC.hashPasswordUsingPolicy bcryptPolicy (LT.encodeUtf8 password)+      -- TODO don't use fromJust+      Db.insertUser loginName (fromJust hashedPass)+      u <- Db.queryUser loginName+      return (Right (Db.fromDbUser . fromJust $ u))+    Just _ ->+      return (Left DuplicateLogin)++-------------------------------------------------------------------------+-- | Login a user+login+  :: T.Text -- ^ Login name of the user logging in+  -> T.Text -- ^ Password+  -> Handler b SqliteJwt (Either AuthFailure User)+login loginName password = do+  user <- Db.queryUser loginName+  case user of+    Nothing ->+      return (Left UnknownUser)+    Just u -> do+      if BC.validatePassword (Db.dbuserHashedPass u) (LT.encodeUtf8 password) then+        passwordOk (Db.fromDbUser u)+      else+        passwordFail++  where+    -- TODO this should return JWT+    passwordOk u = return (Right u)+    passwordFail = return (Left WrongPassword)++parseBearerJwt :: ByteString -> Either String T.Text+parseBearerJwt s = AP.parseOnly (AP.string "Bearer " *> payload) s+  where+    payload = LT.decodeUtf8 <$> AP.takeWhile1 (AP.inClass base64)+    base64 = "A-Za-z0-9+/_=.-"++jwtFromUser :: User -> Handler b SqliteJwt JWT.JSON+jwtFromUser (User uid loginName) = do+  key <- gets siteSecret+  let cs = JWT.def {+            JWT.unregisteredClaims = M.fromList [("id", Number (fromIntegral uid)), ("login", String loginName)]+          }+  return $ JWT.encodeSigned JWT.HS256 key cs++-- | Run a handler with the currently logged in user.+--+-- Verify authentication from the JWT token passed in the Authorization+-- header, and run the user provided 'action' with the logged in user.+--+-- On errors such as missing or malformed JWT or failure to verify the JWT,+-- error out early and issue an HTTP 401 error.+requireAuth :: (User -> Handler b SqliteJwt a) -> Handler b SqliteJwt a+requireAuth action = do+  key <- gets siteSecret+  req <- getRequest+  res <- runExceptT $ do+    authHdr     <- getHeader "Authorization" (rqHeaders req) ?? "Missing Authorization header"+    encPayload  <- hoistEither . parseBearerJwt $ authHdr+    jwt         <- JWT.decode encPayload     ?? "Malformed JWT"+    verifJwt    <- JWT.verify key jwt        ?? "JWT verification failed"+    let unregClaims = JWT.unregisteredClaims (JWT.claims verifJwt)+    -- TODO verify expiration too+    user        <- hoistEither . parseEither parseJSON $ (toObject unregClaims)+    return user+  either (finishEarly 401 . BS8.pack) action res+  where+    toObject = Object . HM.fromList . M.toList++handleLoginError :: AuthFailure -> H b ()+handleLoginError err =+  case err of+    DuplicateLogin -> failLogin dupeError+    UnknownUser    -> failLogin failedPassOrUserError+    WrongPassword  -> failLogin failedPassOrUserError+  where+    dupeError             = "Duplicate login"+    failedPassOrUserError = "Unknown user or wrong password"++    failLogin :: T.Text -> H b ()+    failLogin msg = do+      jsonResponse+      modifyResponse $ setResponseStatus 401 "bad login"+      writeJSON $ object [ "error" .= msg]++loginOK :: User -> Handler b SqliteJwt ()+loginOK user = do+  jwt <- jwtFromUser user+  writeJSON $ object [ "token" .= jwt ]++registerUser :: Handler b SqliteJwt ()+registerUser = method POST newUser+  where+    newUser = do+      params    <- reqJSON+      userOrErr <- createUser (lpLogin params) (lpPass params)+      either handleLoginError loginOK userOrErr++loginUser :: Handler b SqliteJwt ()+loginUser = method POST $ do+  params    <- reqJSON+  userOrErr <- login (lpLogin params) (lpPass params)+  either handleLoginError loginOK userOrErr
+ src/Snap/Snaplet/SqliteSimple/JwtAuth/Types.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.SqliteSimple.JwtAuth.Types where++import           Control.Concurrent+import           Control.Monad+import           Data.Aeson+import qualified Data.Text as T+import           Database.SQLite.Simple+import           Snap+import           Web.JWT as JWT (Secret)++data SqliteJwt = SqliteJwt {+    siteSecret    :: JWT.Secret+  , sqliteJwtConn :: MVar Connection+  }++-- | User account+-- User ID and login name.+--+-- If you need to store additional fields for your user accounts, persist them+-- in your application SQL tables and key them by 'userId'.+data User = User {+    userId    :: Int     -- ^ The database ID of the user account+  , userLogin :: T.Text  -- ^ The login name+  } deriving (Eq, Show)++instance FromJSON User where+  parseJSON (Object v) = User <$> (v .: "id") <*> (v .: "login")+  parseJSON _          = mzero++instance ToJSON User where+  toJSON (User i l) = object [ "id" .= i, "login" .= l ]++data LoginParams = LoginParams {+    lpLogin :: T.Text+  , lpPass  :: T.Text+  }++instance FromJSON LoginParams where+  parseJSON (Object v) = LoginParams <$>+                         v .: "login" <*>+                         v .: "pass"+  parseJSON _          = mzero++-- | Types of errors that can happen on login or new user creation.+data AuthFailure =+    UnknownUser     -- ^ The login name does not exist.+  | DuplicateLogin  -- ^ The login name already exists.+  | WrongPassword   -- ^ Failed the password check.+  deriving (Eq, Show)++data HttpError = HttpError Int String++type H a b = Handler a SqliteJwt b
+ src/Snap/Snaplet/SqliteSimple/JwtAuth/Util.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.SqliteSimple.JwtAuth.Util where++import           Data.Aeson+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS8+import           Data.Int (Int64)+import           Snap+import           System.Directory (doesFileExist)+import           Web.ClientSession (randomKey)++-- | Discard anything after this and return given status code to HTTP+-- client immediately.+finishEarly :: MonadSnap m => Int -> B.ByteString -> m b+finishEarly code str = do+  modifyResponse $ setResponseStatus code str+  modifyResponse $ addHeader "Content-Type" "text/plain"+  writeBS str+  getResponse >>= finishWith++jsonResponse :: MonadSnap m => m ()+jsonResponse = modifyResponse $ setHeader "Content-Type" "application/json"++writeJSON :: (MonadSnap m, ToJSON a) => a -> m ()+writeJSON a = do+  jsonResponse+  writeLBS . encode $ a++-------------------------------------------------------------------------------+-- | Demand the presence of JSON in the body assuming it is not larger+-- than 50000 bytes.+reqJSON :: (MonadSnap m, FromJSON b) => m b+reqJSON = reqBoundedJSON 50000++-------------------------------------------------------------------------------+-- | Demand the presence of JSON in the body with a size up to N+-- bytes. If parsing fails for any reson, request is terminated early+-- and a server error is returned.+reqBoundedJSON+    :: (MonadSnap m, FromJSON a)+    => Int64+    -- ^ Maximum size in bytes+    -> m a+reqBoundedJSON n = do+  res <- getBoundedJSON n+  case res of+    Left e -> finishEarly 400 (BS8.pack e)+    Right a -> return a++-------------------------------------------------------------------------------+-- | Parse request body into JSON or return an error string.+getBoundedJSON+    :: (MonadSnap m, FromJSON a)+    => Int64+    -- ^ Maximum size in bytes+    -> m (Either String a)+getBoundedJSON n = do+  bodyVal <- decode `fmap` readRequestBody (fromIntegral n)+  return $ case bodyVal of+    Nothing -> Left "Can't find JSON data in POST body"+    Just v -> case fromJSON v of+                Error e -> Left e+                Success a -> Right a++-- | Get a key from the given text file.+--+-- If the file does not exist, a random key will be generated and stored in+-- that file.+--+-- This code is borrowed from the clientsession package but it uses a+-- different signature.  We just need the raw ByteString.+getKey :: FilePath           -- ^ File name where key is stored.+       -> IO B.ByteString    -- ^ The actual key.+getKey keyFile = do+    exists <- doesFileExist keyFile+    if exists+        then B.readFile keyFile+        else newKey+  where+    newKey = do+        (bs, _) <- randomKey+        B.writeFile keyFile bs+        return bs