Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add shiny command line parsing interface.

Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
  • Loading branch information...
commit 20a52df35508bddc10e690fabc4e2cb3ffd258f6 1 parent 8a8227b
Edward Z. Yang authored October 15, 2010
2  mmr-hammer.cabal
@@ -14,4 +14,6 @@ Executable mmr-hammer
14 14
     Build-depends:
15 15
         LDAP >= 0.6.6 && < 0.7,
16 16
         containers == 0.3.*,
  17
+        directory == 1.0.*,
  18
+        filepath == 1.1.*,
17 19
         base == 4.*
136  mmr-hammer.hs
... ...
@@ -1,14 +1,25 @@
1  
-{-# LANGUAGE ViewPatterns #-}
  1
+{-# LANGUAGE ViewPatterns, CPP, ScopedTypeVariables #-}
  2
+
  3
+import Prelude hiding (catch)
2 4
 
3 5
 import qualified Data.Set as S
4 6
 import Data.Char
  7
+import Data.Maybe
  8
+import Data.List
  9
+import Data.IORef
5 10
 
6 11
 import Control.Monad
  12
+import Control.Exception
7 13
 
8 14
 import System.IO
  15
+import System.IO.Unsafe
  16
+import System.Exit
9 17
 import System.Environment
  18
+import System.Console.GetOpt
  19
+import System.Directory
  20
+import System.FilePath
10 21
 
11  
-import LDAP.Init (ldapInit, ldapSimpleBind)
  22
+import LDAP.Init (ldapInitialize, ldapSimpleBind)
12 23
 import LDAP.Constants (ldapPort)
13 24
 import LDAP.Search (SearchAttributes(LDAPAllUserAttrs), LDAPEntry(..),
14 25
     LDAPScope(LdapScopeSubtree), ldapSearch)
@@ -129,19 +140,124 @@ restoreBinds ldap statefile = do
129 140
     binds <- fmap read (readFile statefile)
130 141
     ldapModify ldap replicaBase [LDAPMod LdapModAdd "nsDS5ReplicaBindDN" binds]
131 142
 
132  
-createLdap = do
133  
-    -- XXX change this into some legit configuration
134  
-    let server = "localhost"
135  
-    password <- readFile "/etc/signup-ldap-pw"
136  
-    ldap <- ldapInit server ldapPort
137  
-    ldapSimpleBind ldap "cn=Directory Manager" password
  143
+createLdap uri user password = do
  144
+    ldap <- ldapInitialize uri
  145
+    -- XXX LDAP has no support for other bind methods (yet)
  146
+    ldapSimpleBind ldap user password
138 147
     return ldap
139 148
 
  149
+data Password = Password String | AskPassword | NoPassword
  150
+
  151
+data Options = Options {
  152
+      optUri      :: Maybe String
  153
+    , optPassword :: Password
  154
+    , optUser     :: Maybe String
  155
+    , optDebug    :: Bool
  156
+}
  157
+
  158
+defaultOptions = Options {
  159
+      optUri        = Nothing
  160
+    , optPassword   = NoPassword
  161
+    , optUser       = Nothing
  162
+    , optDebug      = False
  163
+}
  164
+
  165
+putOptHost h r = r { optUri = Just ("ldap://" ++ h) }
  166
+putOptPassword p r = r {
  167
+    optPassword = case p of
  168
+        Just p  -> Password p
  169
+        Nothing -> AskPassword
  170
+    }
  171
+
  172
+#define PUT(field) (\x r -> r {field = x})
  173
+#define PUTX(field, x) (\r -> r {field = x})
  174
+#define PUTJ(field) (\x r -> r {field = Just x})
  175
+options =
  176
+    [ Option []    ["uri"]      (ReqArg PUTJ(optUri) "URI")      "URI of LDAP server"
  177
+    , Option ['h'] ["host"]     (ReqArg putOptHost "HOST")       "host, connect with ldap schema"
  178
+    , Option ['p'] ["password"] (OptArg putOptPassword "PASS")   "password"
  179
+    , Option ['u'] ["user"]     (ReqArg PUTJ(optUser) "USER")    "dn of user to bind as"
  180
+    , Option ['d'] ["debug"]    (NoArg  PUTX(optDebug, True))    "debugging output"
  181
+    ]
  182
+
  183
+parseOptions = do
  184
+    argv <- getArgs
  185
+    case getOpt Permute options argv of
  186
+        (optlist, args@(_:_), []) ->
  187
+            return (foldl (flip ($)) defaultOptions optlist, args)
  188
+        (_,_,errs) -> do
  189
+            hPutStr stderr (concat errs ++ usageInfo header options)
  190
+            exitFailure
  191
+    where header = "Usage: mmr-hammer [print|suspend|restore] [binds|agreements]\n"
  192
+
  193
+fillWith opts mUri mUser mPassword= do
  194
+    uri <- case optUri opts of
  195
+        Just uri -> return uri
  196
+        Nothing -> mUri
  197
+    user <- case optUser opts of
  198
+        Just user -> return user
  199
+        Nothing -> mUser
  200
+    password <- case optPassword opts of
  201
+        Password p -> return p
  202
+        AskPassword -> askPassword
  203
+        NoPassword -> mPassword
  204
+    return (uri, user, password)
  205
+
  206
+defaultStrategy opts = do
  207
+    debugIO "Trying defaultStrategy"
  208
+    fillWith opts (error "Missing host") (error "Missing user") (error "Missing password")
  209
+ldapVircStrategy opts = do
  210
+    debugIO "Trying ldapVircStrategy"
  211
+    -- Only supports "default" profile for now
  212
+    home <- getHomeDirectory
  213
+    contents <- lines `fmap` readFile (home </> ".ldapvirc")
  214
+    let parseLdapVirc = do
  215
+        let section = takeWhile (not . isPrefixOf "profile") . tail
  216
+                    . dropWhile (/= "profile default") $ contents
  217
+            getField name = let prefix = name ++ " "
  218
+                            in evaluate . fromJust . stripPrefix prefix . fromJust . find (isPrefixOf prefix) $ section
  219
+        fillWith opts (getField "host") (getField "user") (getField "password")
  220
+    bracketOnError (return ())
  221
+                   (const (warnIO "Failed to parse .ldapvirc"))
  222
+                   (const parseLdapVirc)
  223
+fallbackStrategy opts = do
  224
+    debugIO "Using fallbackStrategy"
  225
+    let mUri = do
  226
+            warnIO "Defaulting to ldap://localhost (try --uri or --host)"
  227
+            return "ldap://localhost"
  228
+        mUser = do
  229
+            warnIO "Defaulting to cn=Directory Manager (try --user)"
  230
+            return "cn=Directory Manager"
  231
+        mPassword = do
  232
+            warnIO "Defaulting to empty password (try --password)"
  233
+            return "" -- XXX semantics not quite right
  234
+    fillWith opts mUri mUser mPassword
  235
+
  236
+askPassword = bracket (hSetEcho stdin False)
  237
+                      (const $ hSetEcho stdin True >> hPutStr stderr "\n")
  238
+                      (const $ hPutStr stderr "Password: " >>
  239
+                               hFlush stderr >>
  240
+                               hGetLine stdin)
  241
+
  242
+tryAll [] = error "tryAll: empty list, please supply fallback"
  243
+tryAll [x] = x
  244
+tryAll (x:xs) = catch x (\(e :: SomeException) -> debugIO ("tryAll: Failed with " ++ show e) >> tryAll xs)
  245
+
  246
+isDebugging = unsafePerformIO (newIORef False)
  247
+{-# NOINLINE isDebugging #-}
  248
+
  249
+debugIO msg = do
  250
+    b <- readIORef isDebugging
  251
+    when b (hPutStrLn stderr $ "DEBUG: " ++ msg)
  252
+warnIO msg = hPutStrLn stderr $ "WARNING: " ++ msg
  253
+
140 254
 main = do
141 255
     let replicasFile = "mmr-hammer-replica"
142 256
         bindsFile    = "mmr-hammer-binds"
143  
-    args <- getArgs
144  
-    ldap <- createLdap
  257
+    (opts, args) <- parseOptions
  258
+    when (optDebug opts) (writeIORef isDebugging True)
  259
+    (uri, user, password) <- tryAll $ [defaultStrategy, ldapVircStrategy, fallbackStrategy] `ap` [opts]
  260
+    ldap <- createLdap uri user password
145 261
     case args of
146 262
         ["print",   "binds"] -> printBinds ldap
147 263
         ["suspend", "binds"] -> suspendBinds ldap bindsFile

0 notes on commit 20a52df

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