X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=blackboard-dns.git;a=blobdiff_plain;f=ServerMain.hs;fp=ServerMain.hs;h=d0a6b8dd5044e90f19986b1bfa9f22c768b9fe75;hp=1e62fe731101a2f3cb94695fb99d0ce4f0b1c110;hb=20021ec127c5574db472d88ff47cbf7e656969f4;hpb=3674500cd498050a48d69d1d30a6139ba3ba88f5

diff --git a/ServerMain.hs b/ServerMain.hs
index 1e62fe7..d0a6b8d 100644
--- a/ServerMain.hs
+++ b/ServerMain.hs
@@ -2,30 +2,13 @@
 module Main where
 
 import           Control.Monad
-import           Control.Monad.Trans
+import           DDNS.Server
+import           DDNS.Server.EditZone
+import           DDNS.Server.SignReq
 import           Data.List
-import           Data.Time.Clock
-{-
-import           DDNS.DBInfo
-import qualified Database.HDBC as RAW
-import qualified Database.HDBC.Sqlite3 as RAW
-import           Database.HaskellDB.DBSpec
-import           Database.HaskellDB.HDBC.SQLite3
--}
 import           OpenSSL
-import           OpenSSL.EVP.PKey
-import           OpenSSL.EVP.Verify
-import           OpenSSL.PEM
-import           OpenSSL.RSA
-import           OpenSSL.X509 as X509
-import           OpenSSL.X509.Request as Req
-import           System.Console.Haskeline
 import           System.Console.ParseArgs
-import           System.Directory
-import           System.FilePath
 import           System.IO
-import           System.Posix.Files
-import           System.Posix.Uname
 
 data Options
     = Help
@@ -90,86 +73,12 @@ main = withOpenSSL $
 
           let lsdir = getRequiredArg m LSDir
           (key, cert) <- ensureWeHaveKeypair lsdir
-
-          case getRequiredArg m Command of
-            "signreq"
-                -> signReq key cert
-            _   -> usageError m ""
-
-ensureWeHaveKeypair :: FilePath -> IO (SomeKeyPair, X509)
-ensureWeHaveKeypair lsdir
-    = do let keyFile  = lsdir </> "server.key"
-             certFile = lsdir </> "server.cert"
-         keyExi <- doesFileExist keyFile
-         cerExi <- doesFileExist certFile
-         if keyExi && cerExi then
-             do key  <- flip readPrivateKey PwNone =<< readFile keyFile
-                cert <- readX509 =<< readFile certFile
-                return (key, cert)
-           else
-             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 RSA keypair..."
-                key <- generateRSAKey 1024 3 Nothing
-                withFile keyFile WriteMode $ \ h ->
-                    writePKCS8PrivateKey key Nothing >>= hPutStr h
-                setFileMode keyFile ownerReadMode
-                putStrLn ("Wrote " ++ keyFile)
-
-                cert <- newX509
-                X509.setVersion      cert 2
-                X509.setSerialNumber cert 1
-                X509.setIssuerName   cert [("CN", fqdn)]
-                X509.setSubjectName  cert [("CN", fqdn)]
-                X509.setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
-                X509.setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
-                X509.setPublicKey    cert key
-                X509.signX509        cert key Nothing
-                withFile certFile WriteMode $ \ h ->
-                    writeX509 cert >>= hPutStr h
-                putStrLn ("Wrote " ++ certFile)
-
-                return (fromKeyPair key, cert)
-
-signReq :: KeyPair k => k -> X509 -> IO ()
-signReq sKey sCert
-    = runInputT (setComplete completeFilename defaultSettings) $
-      do file <- getInputLine "Which X.509 request do you want to sign?: "
-         case file of
-           Just file'@(_:_)
-               -> liftIO $
-                  do req <- readX509Req =<< readFile file'
-                     key <- Req.getPublicKey req
-                     vst <- verifyX509Req req key
-                     unless (vst == VerifySuccess)
-                         $ fail "Invalid X.509 request"
-
-                     cert <- makeX509FromReq req sCert
-                     setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable.
-                     setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
-                     setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
-                     signX509        cert sKey Nothing
-
-                     let certFile = file' `replaceExtension` ".cert"
-                     withFile certFile WriteMode $ \ h ->
-                         writeX509 cert >>= hPutStr h
-                     putStrLn ("Wrote " ++ certFile)
-
-                     Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False
-                     putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".")
-           _   -> return ()
-
-{-
-main = do sqliteConnect "ddns.db" $ \ db ->
-              dbSpecToDatabase db dbinfo
-
-          rawCon <- RAW.connectSqlite3 "ddns.db"
-          mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
-          RAW.commit rawCon
-          RAW.disconnect rawCon
--}
\ No newline at end of file
+          withDB      <- ensureWeHaveDB lsdir
+
+          withDB $ \ db ->
+              case getRequiredArg m Command of
+                "signreq"
+                    -> signReq key cert
+                "editzone"
+                    -> editZone db
+                _   -> usageError m ""