Permalink
Browse files

Implement choosing between old/new data with Monoids

  • Loading branch information...
dzhus committed Feb 29, 2012
1 parent 38a6018 commit 31084e30cadd2e9628d773b61255bc793b3e630a
Showing with 47 additions and 5 deletions.
  1. +17 −0 README.org
  2. +30 −5 src/Main.hs
View
@@ -60,6 +60,23 @@
: ./snap-auth-cli -j back.json --create -u MimsyBorogove -p 0utgr@b3d
+ 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 new password for user:
+
+ : ./snap-auth-cli -m -u Mome -p r@th$$
+
+ Set 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, but JsonFile backend
in Snap doesn't support the operation yet.
View
@@ -13,6 +13,7 @@ module Main
where
import Data.Functor
+import Data.Monoid
import Data.Aeson.Encode.Pretty
import qualified Data.Aeson.Types as A
@@ -38,19 +39,43 @@ type AuthUserAction = IAuthBackend r => r -> AuthUser -> IO ()
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.
+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 has 'Nothing' in password, old password will be
-- used.
makeUpdateAction :: AuthUser -> AuthUserAction
makeUpdateAction newUser =
\amgr oldUser ->
let
- newPw = case (userPassword newUser) of
- Nothing -> userPassword oldUser
- pw@(Just _) -> pw
- in do
+ pick how = getContainer $ mconcat $
+ map (NullMonoid . how) [newUser, oldUser]
+ in
save amgr newUser{ userId = userId oldUser
- , userPassword = newPw
+ , userPassword = pick userPassword
+ , userRoles = pick userRoles
+ , userMeta = pick userMeta
}
>> return ()

0 comments on commit 31084e3

Please sign in to comment.