diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/snaplet-sqlite-simple-jwt-auth.cabal b/snaplet-sqlite-simple-jwt-auth.cabal new file mode 100644 --- /dev/null +++ b/snaplet-sqlite-simple-jwt-auth.cabal @@ -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: + . + For more info, browse to 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 + diff --git a/src/Snap/Snaplet/SqliteSimple/JwtAuth.hs b/src/Snap/Snaplet/SqliteSimple/JwtAuth.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SqliteSimple/JwtAuth.hs @@ -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 +-- +-- has a walk-through of the application's source code. diff --git a/src/Snap/Snaplet/SqliteSimple/JwtAuth/Db.hs b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Db.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Db.hs @@ -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) diff --git a/src/Snap/Snaplet/SqliteSimple/JwtAuth/JwtAuth.hs b/src/Snap/Snaplet/SqliteSimple/JwtAuth/JwtAuth.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SqliteSimple/JwtAuth/JwtAuth.hs @@ -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 diff --git a/src/Snap/Snaplet/SqliteSimple/JwtAuth/Types.hs b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Types.hs @@ -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 diff --git a/src/Snap/Snaplet/SqliteSimple/JwtAuth/Util.hs b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Util.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/SqliteSimple/JwtAuth/Util.hs @@ -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