Skip to content
Browse files

Port to cmdargs, which reduces amount of boilerplate and is more expr…

…essive
  • Loading branch information...
1 parent 3a62d7c commit 0653da87a07a3d0d7e35a2af0e077c93f90aac97 @dzhus committed
Showing with 61 additions and 88 deletions.
  1. +1 −0 snap-auth-cli.cabal
  2. +60 −88 src/Main.hs
View
1 snap-auth-cli.cabal
@@ -23,6 +23,7 @@ executable snap-auth-cli
base >= 4 && < 5,
bytestring == 0.9.*,
clientsession == 0.7.*,
+ cmdargs == 0.9.*,
snap >= 0.7.1 && < 0.8,
text == 0.11.*,
utf8-string == 0.3.*
View
148 src/Main.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RecordWildCards #-}
{-|
@@ -18,122 +20,92 @@ import qualified Data.Text as T (pack)
import qualified Data.ByteString.Lazy as LB (putStr)
import qualified Data.ByteString.UTF8 as B (fromString)
-import System.Console.GetOpt
-import System.Environment
+import System.Console.CmdArgs.Implicit
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
-import Web.ClientSession
-
-
--- | Possible modes of operation.
-data Mode = Create | Delete | Show'
- deriving Show
-
--- | Holds all options passed from command-line.
-data Options = Options
- {
- optMode :: Maybe Mode
- , optLogin :: Maybe String
- , optPassword :: Maybe String
- , optJson :: String
- }
- deriving Show
+import Web.ClientSession
--- | Default program options (no-op).
-defaultOptions :: Options
-defaultOptions = Options
- {
- optMode = Nothing
- , optLogin = Nothing
- , optPassword = Nothing
- , optJson = "users.json"
- }
+-- | Rank-2 type for action applicable to AuthManager and AuthUser.
+type AuthUserAction = IAuthBackend r => r -> AuthUser -> IO ()
-- | Save new user in auth backend given user login and password
-mgrNewUser :: IAuthBackend r =>
- r
- -> (String, String)
- -> IO AuthUser
+mgrNewUser :: IAuthBackend r => r
+ -> (String, String)
+ -> IO AuthUser
mgrNewUser amgr (l, p) =
let
login = T.pack l
pass = B.fromString p
- user' = defAuthUser{userLogin = login}
+ au' = defAuthUser{userLogin = login}
in
do
- user <- setPassword user' pass
- save amgr user
-
+ au <- setPassword au' pass
+ save amgr au
-type AuthUserAction = IAuthBackend r => r -> AuthUser -> IO ()
-- | Get user from backend by login and apply 'AuthUserAction' to it.
-mgrOldUser :: IAuthBackend r => r -> String -> AuthUserAction -> IO ()
+mgrOldUser :: IAuthBackend r => r
+ -> String
+ -> AuthUserAction
+ -> IO ()
mgrOldUser amgr l f =
let
login = T.pack l
in
do
- user <- lookupByLogin amgr login
- case user of
+ au <- lookupByLogin amgr login
+ case au of
Just found -> f amgr found
Nothing -> ioError $ userError $
l ++ ": user not found"
+-- | Possible modes of operation.
+data OpMode = Create | Read | Delete
+ deriving (Show, Data, Typeable)
+
+-- | Default instance for CmdArg.
+instance Default OpMode where
+ def = Read
+
+
+-- | Holds all options passed from command-line.
+data Options = Options
+ { mode :: OpMode
+ , user :: Maybe String
+ , password :: Maybe String
+ , json :: String
+ }
+ deriving (Show, Data, Typeable)
+
+
main :: IO ()
main =
let
- options :: [OptDescr (Options -> Options)]
- options =
- [
- Option ['c'] ["create"]
- (NoArg $ \opts -> opts{optMode = Just Create})
- "Create new user"
- , Option ['d'] ["delete"]
- (NoArg $ \opts -> opts{optMode = Just Delete})
- "Delete user"
- , Option ['w'] ["show"]
- (NoArg $ \opts -> opts{optMode = Just Show'})
- "Show user"
- , Option ['u'] ["user", "name"]
- (ReqArg (\u opts -> opts{optLogin = Just u}) "USER")
- "User login"
- , Option ['p'] ["password"]
- (ReqArg (\p opts -> opts{optPassword = Just p}) "PWD")
- "User password"
- , Option ['j'] ["json"]
- (ReqArg (\j opts -> opts{optJson = j}) "JSONFILE")
- "JsonFile backend storage file"
- ]
- header = "Usage: snap-auth-cli [OPTIONS]"
- in
- do
- -- Parse command-line args into Options opts
- getopts <- getOpt Permute options <$> getArgs
- opts <- case getopts of
- ([], _, _) -> ioError $ userError $ usageInfo header options
- (o, _, []) -> return $ foldl (flip id) defaultOptions o
- (_, _, errs) -> ioError $ userError $
- concat errs ++ usageInfo header options
-
- -- Load JSON database using file specified in -j
- amgr <- mkJsonAuthMgr (optJson opts)
-
- -- Operate depending on mode selected
- case (optMode opts, optLogin opts, optPassword opts) of
- (Nothing, _, _) -> ioError (userError "No operation mode selected")
- (_, Nothing, _) -> ioError $ userError "No user selected"
-
- (Just Show', Just l, _) -> mgrOldUser amgr l
- (\_ u -> LB.putStr $ encodePretty u)
-
- (Just Delete, Just l, _) -> mgrOldUser amgr l destroy
-
- (Just Create, Just l, Just p) -> mgrNewUser amgr (l, p)
- >> return ()
- (Just Create, _, Nothing) -> ioError $ userError "No password set"
+ sample = Options
+ { mode = enum [Read &= help "Read existing user"
+ , Create &= help "Create new user"
+ , Delete &= help "Delete user"]
+ , user = def &= help "User login"
+ , password = def
+ , json = "users.json"
+ &= typFile
+ &= help "Path to JsonFile database"
+ }
+ &= program "snap-auth-cli"
+ in do
+ -- RecordWildCards
+ Options{..} <- cmdArgs $ sample
+ amgr <- mkJsonAuthMgr json
+ case (mode, user, password) of
+ (_, Nothing, _) -> ioError $ userError "No user selected"
+ (Read, Just l, _) -> mgrOldUser amgr l
+ (\_ au -> LB.putStr $ encodePretty au)
+ (Delete, Just l, _) -> mgrOldUser amgr l destroy
+ (Create, Just l, Just pw) -> mgrNewUser amgr (l, pw)
+ >> return ()
+ (Create, _, Nothing) -> ioError $ userError "No password set"

0 comments on commit 0653da8

Please sign in to comment.
Something went wrong with that request. Please try again.