client makereq

[blackboard-dns.git] / ClientMain.hs

diff --git a/ClientMain.hs b/ClientMain.hs
new file mode 100644 (file)
index 0000000..b3090b3
--- /dev/null
+++ b/ClientMain.hs
@@ -0,0 +1,81 @@
+module Main where
+
+import           Control.Monad
+import           Control.Monad.Trans
+import           OpenSSL
+import           OpenSSL.PEM
+import           OpenSSL.RSA
+import           OpenSSL.X509.Request
+import           System.Console.Haskeline
+import           System.Console.ParseArgs
+import           System.IO
+import           System.Posix.Files
+import           System.Posix.Uname
+
+
+data Options
+    = Help
+    | Command
+    deriving (Show, Eq, Ord)
+
+arginfo :: [Arg Options]
+arginfo = [ Arg {
+              argIndex = Help
+            , argAbbr  = Just 'h'
+            , argName  = Nothing
+            , argData  = Nothing
+            , argDesc  = "print this help."
+            }
+          , Arg {
+              argIndex = Command
+            , argAbbr  = Nothing
+            , argName  = Nothing
+            , argData  = argDataDefaulted "COMMAND" ArgtypeString "update"
+            , argDesc  = "command to the client (default: \"update\")."
+            }
+          ]
+
+main :: IO ()
+main = withOpenSSL $
+       do m <- parseArgsIO ArgsComplete arginfo
+          when (gotArg m Help)
+                   $ usageError m ""
+
+          case getRequiredArg m Command of
+            "makereq"
+                -> makeReq
+            _   -> usageError m ""
+
+
+makeReq :: IO ()
+makeReq
+    = do fqdn <- runInputT defaultSettings $
+                 do defaultFqdn <- liftM uNodeName $ liftIO uname
+                    fqdn        <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ")
+                    case fqdn of
+                      Just s@(_:_) -> return s
+                      _            -> return defaultFqdn
+
+         putStrLn "Generating keypair..."
+         key <- generateRSAKey 1024 3 Nothing
+
+         let pubFile = fqdn ++ ".pub"
+         withFile pubFile WriteMode $ \ h ->
+             writePublicKey key >>= hPutStr h
+         putStrLn ("Wrote " ++ pubFile)
+
+         let keyFile = fqdn ++ ".key"
+         withFile keyFile WriteMode $ \ h ->
+             writePKCS8PrivateKey key Nothing >>= hPutStr h
+         setFileMode keyFile (ownerReadMode `unionFileModes` ownerWriteMode)
+         putStrLn ("Wrote " ++ keyFile ++ " (with no encryption)")
+
+         req <- newX509Req
+         setVersion     req 2
+         setSubjectName req [("CN", fqdn)]
+         setPublicKey   req key
+         let reqFile = fqdn ++ ".req"
+         withFile reqFile WriteMode $ \ h ->
+             writeX509Req req ReqNewFormat >>= hPutStr h
+         putStrLn ("Wrote " ++ reqFile)
+         putStrLn ("Now send " ++ reqFile ++ " to the server operator and tell him/her to sign it.")
\ No newline at end of file