diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/snap-auth-cli.cabal b/snap-auth-cli.cabal new file mode 100644 --- /dev/null +++ b/snap-auth-cli.cabal @@ -0,0 +1,45 @@ +name: snap-auth-cli +version: 0.1.0.0 +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.4.1 + +source-repository head + type: git + location: git://github.com/dzhus/snap-auth-cli.git + +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.9.*, + clientsession == 0.7.*, + cmdargs == 0.9.*, + snap == 0.8.*, + text == 0.11.*, + unordered-containers >= 0.1.4 && < 0.3, + utf8-string == 0.3.* diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + +Main module. + +-} + +module Main + +where + +import Data.Functor +import Data.Monoid + +import Data.Aeson.Encode.Pretty +import qualified Data.Aeson.Types as A + +import qualified Data.Text as T (pack) +import qualified Data.ByteString.Lazy as LB (putStr) +import qualified Data.ByteString.UTF8 as BU (fromString) +import qualified Data.HashMap.Lazy as M + +import System.Console.CmdArgs.Implicit + +import Snap.Snaplet.Auth +import Snap.Snaplet.Auth.Backends.JsonFile + + +-- | Rank-2 type for action applicable to AuthManager and AuthUser. +type AuthUserAction = IAuthBackend r => r -> AuthUser -> IO () + + +-- | Action for --read mode: show pretty JSON auth user entry. +readAction :: AuthUserAction +readAction _ au = LB.putStr $ encodePretty au + + +-- | Containers for which null predicate is defined. +class PossiblyNull a where + null :: a + +instance PossiblyNull [a] where + null = [] + +instance PossiblyNull (Maybe a) where + null = Nothing + +instance PossiblyNull (M.HashMap k v) where + null = M.empty + +-- | Monoid under choosing non-null container. +-- +-- We can map empty containers to Nothing and use standard monoid for +-- 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) = + NullMonoid (if x == Main.null then y else x) + + +-- | 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 -> + let + pick how = getContainer $ mconcat $ + map (NullMonoid . how) [newUser, oldUser] + in + 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. +-- +-- Has to be monadic due to 'setPassword' usage (hashing requires IO) +-- (in case of non-'Nothing' password). +buildAuthUser :: String -- ^ User + -> Maybe String -- ^ Password + -> [String] -- ^ Roles + -> [(String, String)] -- ^ List of key-value pairs of + -- user metadata + -> IO AuthUser +buildAuthUser l p rs mt = + let + login = T.pack l + pass = BU.fromString <$> p + 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 + , userRoles = roles + , userMeta = meta + } + in + do + case pass of + Nothing -> return au' + Just pw -> setPassword au' pw + + +-- | Get user from backend by login and apply 'AuthUserAction' to it. +mgrOldUser :: IAuthBackend r => r + -> String + -> AuthUserAction + -> IO () +mgrOldUser amgr l f = + let + login = T.pack l + in + do + 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 | Modify | 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 + , role :: [String] + , key :: [String] + , value :: [String] + } + deriving (Show, Data, Typeable) + + +modifyHelp :: String +modifyHelp = "Modify password or replace roles and meta of existing user. " ++ + "If any of -p/-r/-k,-v flags is not set, previous value " ++ + "of that flag is preserved for account" + + +main :: IO () +main = + let + sample = Options + { mode = + enum [ Read &= help "Read existing user" + , Create &= help "Create new user" + , Modify &= help modifyHelp + , Delete &= help "Delete user"] &= groupname "Mode" + , user = def &= help "User login" &= groupname "Other flags" + , password = def + , role = def &= name "o" + &= help "User role. May be specified multiple times" + , key = def &= name "k" + &= 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" + } + &= 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 readAction + (Delete, Just l, _) -> mgrOldUser amgr l destroy + -- Require password for new users + (Create, _, Nothing) -> ioError $ userError "No password set" + (_, Just l, pw) -> + do + au <- buildAuthUser l pw role (zip key value) + case mode of + Modify -> mgrOldUser amgr l (makeUpdateAction au) >> return () + Create -> save amgr au >> return ()