From 8109d2350f4c2855cd65b63c14efcb70fa3473c7 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 5 Jun 2009 16:14:45 +0900
Subject: [PATCH] client makereq

---
 ClientMain.hs         | 81 +++++++++++++++++++++++++++++++++++++++++++
 GNUmakefile           |  3 +-
 ServerMain.hs         |  4 +--
 System/Posix/Uname.hs | 29 ++++++++++++++++
 blackboard-dns.cabal  | 14 ++++++++
 5 files changed, 128 insertions(+), 3 deletions(-)
 create mode 100644 ClientMain.hs
 create mode 100644 System/Posix/Uname.hs

diff --git a/ClientMain.hs b/ClientMain.hs
new file mode 100644
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
diff --git a/GNUmakefile b/GNUmakefile
index 2bb908f..b3350fe 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -1,4 +1,5 @@
-RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server
+#RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server
+RUN_COMMAND = ./dist/build/bbdns-client/bbdns-client makereq
 
 include cabal-package.mk
 
diff --git a/ServerMain.hs b/ServerMain.hs
index 833256f..5f0db30 100644
--- a/ServerMain.hs
+++ b/ServerMain.hs
@@ -69,9 +69,9 @@ arginfo = [ Arg {
 main :: IO ()
 main = do m <- parseArgsIO ArgsComplete arginfo
           when (gotArg m Help)
-                   $ usageError m "" `seq` return ()
+                   $ usageError m ""
 
-          usageError m "" `seq` return ()
+          usageError m ""
 
 {-
 main = do sqliteConnect "ddns.db" $ \ db ->
diff --git a/System/Posix/Uname.hs b/System/Posix/Uname.hs
new file mode 100644
index 0000000..1a57ed1
--- /dev/null
+++ b/System/Posix/Uname.hs
@@ -0,0 +1,29 @@
+module System.Posix.Uname
+    ( Uname(..)
+    , uname
+    )
+    where
+
+import qualified Bindings.Uname as U
+import Foreign.C
+import Foreign.Marshal
+
+data Uname
+    = Uname {
+        uSysName  :: String
+      , uNodeName :: String
+      , uRelease  :: String
+      , uVersion  :: String
+      , uMachine  :: String
+      }
+    deriving (Show, Eq, Ord)
+
+uname :: IO Uname
+uname = alloca $ \ ptr ->
+        do throwErrnoIfMinus1_ "uname" (U.uname ptr)
+           sys <- peekCString $ U.sysname  ptr
+           nod <- peekCString $ U.nodename ptr
+           rel <- peekCString $ U.release  ptr
+           ver <- peekCString $ U.version  ptr
+           mac <- peekCString $ U.machine  ptr
+           return $ Uname sys nod rel ver mac
diff --git a/blackboard-dns.cabal b/blackboard-dns.cabal
index b66aa22..5e955b3 100644
--- a/blackboard-dns.cabal
+++ b/blackboard-dns.cabal
@@ -32,3 +32,17 @@ Executable bbdns-server
 
     GHC-Options:
         -Wall
+
+Executable bbdns-client
+    Build-Depends:
+        HsOpenSSL, base, bindings-uname, haskeline, mtl, parseargs,
+        unix
+
+    Other-Modules:
+        System.Posix.Uname
+
+    Main-Is:
+        ClientMain.hs
+
+    GHC-Options:
+        -Wall
-- 
2.40.0