diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,21 @@ +# Changelog + +## [0.2] - 2018-03-15 + +### Added + +- SQLite support (contributed by Pedro Baltazar Vasconcelos + ) + +### Changed + +- `-f` flag is now used to specify the database file location instead + of `-j` + +## [0.1.0.1] - 2012-12-03 + +## [0.1.0.0] - 2012-04-04 + +[0.2]: https://github.com/dzhus/snap-auth-cli/compare/0.1.0.1...0.2 +[0.1.0.1]: https://github.com/dzhus/snap-auth-cli/compare/0.1.0.0...0.1.0.1 +[0.1.0.0]: https://github.com/dzhus/snap-auth-cli/tree/0.1.0.0 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,105 @@ +# snap-auth-cli: CLI tool to manage Snap auth database + +[![Travis CI build status](https://travis-ci.org/dzhus/snap-auth-cli.svg)](https://travis-ci.org/dzhus/snap-auth-cli) +[![Hackage](https://img.shields.io/hackage/v/snap-auth-cli.svg?colorB=5e5184&style=flat)](https://hackage.haskell.org/package/snap-auth-cli) +[![Hackage deps](https://img.shields.io/hackage-deps/v/snap-auth-cli.svg)](http://packdeps.haskellers.com/feed?needle=snap-auth-cli) + +This tool provides command-line interface to +Haskell [Snap][snap] [AuthManager][snap-auth] to create, view and +delete users in database. Currently the Json and Sqlite file backends are +supported. + +Passwords for new users are provided in plain text. + +By default the database resides in current directory in `users.json` +file. A different db may be specified using `-f` flag. +To specify a Sqlite database use `-s -f filename`. + +# How to use + +Type `snap-auth-cli --help` to get usage help. + +Create a user: + + $ snap-auth-cli --create -u TwasBrillig -p SlithyToves1855 + +User roles may be set when creating account using arbitary number +of `-o` flags: + + $ snap-auth-cli --create -u TwasBrillig2 -p SlithyToves1855 -o gyre -o gimble + +A user may have an arbitary number of key-value pairs attached in the +meta field (currently all fields are stored in Strings): + + $ snap-auth-cli --create -u AlexP -p 1234 -k number -v 3214 -k foo -v bar -o admin + +Read a user from DB (`--read` flag may be omitted since reading +is the default mode): + + $ snap-auth-cli --read -u AlexP + +```json +{ + "meta": { + "number": "3214", + "foo": "bar" + }, + "suspended_at": null, + "roles": [ + "admin" + ], + "pw": "sha256|12|VpUGBg2O/NBkDTVTSqqYuA==|TIDuc3ToAPmALXCHBxTA8SjlUBztPS8nH6qiV63a+f4=", + "activated_at": null, + "current_ip": null, + "locked_until": null, + "updated_at": "2012-02-22T09:00:29.377Z", + "login_count": 0, + "current_login_at": null, + "login": "AlexP", + "remember_token": null, + "failed_login_count": 0, + "last_ip": null, + "last_login_at": null, + "uid": "1", + "created_at": null +} +``` + +To specify a different database file (Json by default): + + $ snap-auth-cli -f back.json --create -u MimsyBorogove -p 0utgr@b3d + +Note that if database file doesn't exist, it will be created from +scratch. + +To specify a Sqlite database: + + $ snap-auth-cli -s -f db.sqlite --read -u AlexP + +Unlike the Json backend, the database file with the correct schema +must aleady exist; this should be automaticallly initialized by +when you first run the Snap application. + + +Existing users can be modified using the `-m` option. User is +selected by login. Any of `-p`, `-o` or `-k/-v` flags may be +specified to set new value for user password, roles or meta. If no +new value is provided, old field is preserved. + +Set a new password for user: + + $ snap-auth-cli -m -u Mome -p r@th$$ + +Set a new role: + + $ snap-auth-cli -m -u Mome -o foobarer + +Replace user meta: + + $ snap-auth-cli -m -u BG -k tel -v 2-12-85-06 + +The tool provides interface to delete users; the Sqlite backend supports +this operation but the JsonFile backend does not. + +[snap]: http://snapframework.com/ +[snap-auth]: http://hackage.haskell.org/package/snap/docs/Snap-Snaplet-Auth.html diff --git a/snap-auth-cli.cabal b/snap-auth-cli.cabal --- a/snap-auth-cli.cabal +++ b/snap-auth-cli.cabal @@ -1,45 +1,42 @@ -name: snap-auth-cli -version: 0.1.0.1 -synopsis: Command-line tool to manage Snap AuthManager database - -description: This utility provides command-line interface to user - database of standard authentication system for - the Snap web framework. You can create, read and - update users, set passwords, roles and meta - information. Currently only JsonFile backend is - supported. Type @snap-auth-cli -?@ to get usage - information, or see - - for details. - -homepage: https://github.com/dzhus/snap-auth-cli -license: BSD3 -license-file: LICENSE -author: Dmitry Dzhus -maintainer: dima@dzhus.org -category: Web, Snap -build-type: Simple -cabal-version: >=1.8 -tested-with: GHC == 7.6.1 +cabal-version: >=1.10 +name: snap-auth-cli +version: 0.2 +license: BSD3 +license-file: LICENSE +maintainer: dima@dzhus.org +author: Dmitry Dzhus +homepage: https://github.com/dzhus/snap-auth-cli#readme +bug-reports: https://github.com/dzhus/snap-auth-cli/issues +synopsis: Command-line tool to manage Snap AuthManager database +description: + This utility provides command-line interface to user database of standard authentication system for the Snap web framework. You can create, read and update users, set passwords, roles and meta information. Currently only JsonFile backend is supported. Type `snap-auth-cli -?` to get usage information, or see README.md for details. +category: Web, Snap +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md source-repository head - type: git - location: git://github.com/dzhus/snap-auth-cli.git + type: git + location: https://github.com/dzhus/snap-auth-cli executable snap-auth-cli - hs-source-dirs: src - main-is: Main.hs - - ghc-options: -Wall - - build-depends: - aeson == 0.6.*, - aeson-pretty == 0.6.*, - base >= 4 && < 5, - bytestring == 0.10.*, - clientsession == 0.8.*, - cmdargs == 0.10.*, - snap == 0.9.*, - text == 0.11.*, - unordered-containers >= 0.1.4 && < 0.3, - utf8-string == 0.3.* + main-is: Main.hs + hs-source-dirs: src + other-modules: + Paths_snap_auth_cli + default-language: Haskell2010 + ghc-options: -Wall -Wcompat + build-depends: + aeson <1.2, + aeson-pretty <0.9, + base <5, + bytestring <0.11, + clientsession <0.10, + cmdargs <0.11, + snap <1.1, + snaplet-sqlite-simple <1.1, + sqlite-simple <0.5, + text <1.3, + unordered-containers <0.3, + utf8-string <1.1 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,20 +1,14 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} - -{-| - -Main module. - --} +{-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Functor -import Data.Monoid - +import Control.Monad +import Data.Semigroup import Data.Aeson.Encode.Pretty import qualified Data.Aeson.Types as A @@ -27,10 +21,15 @@ import Snap.Snaplet.Auth import Snap.Snaplet.Auth.Backends.JsonFile +import Snap.Snaplet.Auth.Backends.SqliteSimple +import Database.SQLite.Simple +import Control.Concurrent.MVar +import Control.Exception (finally) + -- | Rank-2 type for action applicable to AuthManager and AuthUser. -type AuthUserAction = IAuthBackend r => r -> AuthUser -> IO () +type AuthUserAction = forall r. IAuthBackend r => r -> AuthUser -> IO () -- | Action for --read mode: show pretty JSON auth user entry. @@ -57,28 +56,29 @@ -- Nothing as well. newtype NullMonoid a = NullMonoid { getContainer :: a } -instance (Eq a, PossiblyNull a) => Monoid (NullMonoid a) where - mempty = NullMonoid Main.null - (NullMonoid x) `mappend` (NullMonoid y) = +instance (Eq a, PossiblyNull a) => Semigroup (NullMonoid a) where + (NullMonoid x) <> (NullMonoid y) = NullMonoid (if x == Main.null then y else x) +instance (Eq a, PossiblyNull a) => Monoid (NullMonoid a) where + mempty = NullMonoid Main.null + mappend = (<>) -- | Make 'AuthUserAction' which will replace user with the supplied -- one. In case new user record does not set new password, roles or -- meta, preserve old values. makeUpdateAction :: AuthUser -> AuthUserAction -makeUpdateAction newUser = - \amgr oldUser -> +makeUpdateAction newUser amgr oldUser = let pick how = getContainer $ mconcat $ map (NullMonoid . how) [newUser, oldUser] in + void $ save amgr newUser{ userId = userId oldUser , userPassword = pick userPassword , userRoles = pick userRoles , userMeta = pick userMeta } - >> return () -- | Create new AuthUser object from data supplied from command line. @@ -95,7 +95,7 @@ let login = T.pack l pass = BU.fromString <$> p - roles = map (Role . BU.fromString) $ rs + roles = map (Role . BU.fromString) rs meta = M.fromList $ map (\(k, v) -> (T.pack k, A.String $ T.pack v)) mt au' = defAuthUser{ userLogin = login @@ -103,7 +103,6 @@ , userMeta = meta } in - do case pass of Nothing -> return au' Just pw -> setPassword au' pw @@ -131,17 +130,27 @@ deriving (Show, Data, Typeable) +-- | user backend +data Backend = Json | Sqlite + deriving (Show, Data, Typeable) + + -- | Default instance for CmdArg. instance Default OpMode where def = Read +instance Default Backend where + def = Json + + -- | Holds all options passed from command-line. data Options = Options { mode :: OpMode , user :: Maybe String , password :: Maybe String - , json :: String + , backend :: Backend + , file :: FilePath , role :: [String] , key :: [String] , value :: [String] @@ -172,16 +181,31 @@ &= help "User meta key. Must be followed by value option" , value = def &= name "v" &= help "User meta value." - , json = "users.json" - &= typFile - &= help "Path to JsonFile database" + , backend = + enum [ Json &= help "Use the Json file backend" + , Sqlite &= help "Use the Sqlite file backend" + ] &= groupname "User database backend" + , file = "users.json" &= typFile + &= help "Path to database file" } &= program "snap-auth-cli" in do -- RecordWildCards - Options{..} <- cmdArgs $ sample - amgr <- mkJsonAuthMgr json - case (mode, user, password) of + opts@Options{..} <- cmdArgs sample + case backend of + Json -> do + amgr <- mkJsonAuthMgr file + withAuthMgr opts amgr + Sqlite -> do + conn <- open file + mv <- newMVar conn + let amgr = mkSqliteAuthMgr "snap_auth_user" mv + withAuthMgr opts amgr `finally` close conn + + +withAuthMgr :: IAuthBackend r => Options -> r -> IO () +withAuthMgr Options{..} amgr = + case (mode, user, password) of (_, Nothing, _) -> ioError $ userError "No user selected" (Read, Just l, _) -> mgrOldUser amgr l readAction (Delete, Just l, _) -> mgrOldUser amgr l destroy @@ -191,5 +215,6 @@ do au <- buildAuthUser l pw role (zip key value) case mode of - Modify -> mgrOldUser amgr l (makeUpdateAction au) >> return () - Create -> save amgr au >> return () + Modify -> void $ mgrOldUser amgr l (makeUpdateAction au) + Create -> void $ save amgr au + _ -> error "Incompatible mode and options"