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
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 ""