Permalink
Browse files

CLI tool to manage Snap AuthManager database

  • Loading branch information...
0 parents commit a3540f731fcee30254dfe7a54350663850267be9 @dzhus committed Feb 19, 2012
Showing with 184 additions and 0 deletions.
  1. +4 −0 .hgignore
  2. +30 −0 LICENSE
  3. +2 −0 Setup.hs
  4. +26 −0 snap-auth-cli.cabal
  5. +122 −0 src/Main.hs
@@ -0,0 +1,4 @@
+syntax: glob
+cabal-dev/*
+dist/*
+
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Dmitry Dzhus
+
+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 Dmitry Dzhus 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.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,26 @@
+name: snap-auth-cli
+version: 0.1.0.0
+synopsis: Command-line tool to manage Snap AuthManager database
+-- description:
+homepage: https://github.com/dzhus/snap-auth-cli
+license: BSD3
+license-file: LICENSE
+author: Dmitry Dzhus
+maintainer: dima@dzhus.org
+category: Web
+build-type: Simple
+cabal-version: >=1.8
+tested-with: GHC == 7.4.1
+
+executable snap-jsonauth-cli
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ ghc-options: -Wall
+
+ build-depends:
+ base >= 4 && < 5,
+ clientsession == 0.7.*,
+ snap >= 0.7.1 && < 0.8,
+ text == 0.11.*,
+ utf8-string == 0.3.*
@@ -0,0 +1,122 @@
+{-|
+
+Command-line tool to manage 'Snap.Snaplet.Auth.AuthManager' database
+which uses 'Snap.Snaplet.Auth.Backends.JsonFile' backend.
+
+User database resides in @users.json@ file in current directory,
+encryption key is stored in @client_session_key.aes@. If database or
+key is not present, they will be generated from scratch.
+
+-}
+
+module Main
+
+where
+
+import Data.Functor
+
+import qualified Data.Text as T (pack)
+import qualified Data.ByteString.UTF8 as B (fromString)
+
+import System.Console.GetOpt
+import System.Environment
+
+import Snap.Snaplet.Auth
+import Snap.Snaplet.Auth.Backends.JsonFile
+import Web.ClientSession
+
+
+-- | Possible modes of operation.
+data Mode = Create | Delete
+ deriving Show
+
+
+-- | Holds all options passed from command-line.
+data Options = Options
+ {
+ optMode :: Maybe Mode
+ , optLogin :: Maybe String
+ , optPassword :: Maybe String
+ }
+ deriving Show
+
+
+-- | Default program options (no-op).
+defaultOptions :: Options
+defaultOptions = Options
+ {
+ optMode = Nothing
+ , optLogin = Nothing
+ , optPassword = Nothing
+ }
+
+
+-- | Save new user in auth backend given user login and password
+mgrSaveUser :: IAuthBackend r =>
+ r
+ -> (String, String)
+ -> IO AuthUser
+mgrSaveUser amgr (l, p) =
+ let
+ login = T.pack l
+ pass = B.fromString p
+ user' = defAuthUser{userLogin = login}
+ in
+ do
+ user <- setPassword user' pass
+ save amgr user
+
+
+-- | Try to delete user in auth backend given user login
+mgrDeleteUser :: IAuthBackend r => r -> String -> IO ()
+mgrDeleteUser amgr l =
+ let
+ login = T.pack l
+ in
+ do
+ user <- lookupByLogin amgr login
+ case user of
+ Just found -> destroy amgr found
+ Nothing -> ioError $ userError $
+ l ++ ": user not found"
+
+
+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 ['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"
+ ]
+ in
+ do
+ -- Parse command-line args into Options opts
+ getopts <- getOpt Permute options <$> getArgs
+ opts <- case getopts of
+ (o, _, []) -> return $ foldl (flip id) defaultOptions o
+ (_, _, errs) -> ioError $ userError $
+ concat errs ++ usageInfo header options
+ where header = "Usage: snap-jsonauth-cli [OPTIONS]"
+
+ amgr <- mkJsonAuthMgr "users.json"
+
+ -- 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 Delete, Just l, _) -> mgrDeleteUser amgr l
+ (Just Create, Just l, Just p) -> mgrSaveUser amgr (l, p)
+ >> return ()
+ (Just Create, _, Nothing) -> ioError $ userError "No password set"

0 comments on commit a3540f7

Please sign in to comment.