Split commands off

[blackboard-dns.git] / DDNS / Server.hs

diff --git a/DDNS/Server.hs b/DDNS/Server.hs
new file mode 100644 (file)
index 0000000..aedeadd
--- /dev/null
+++ b/DDNS/Server.hs
@@ -0,0 +1,82 @@
+module DDNS.Server
+    ( ensureWeHaveKeypair
+    , ensureWeHaveDB
+    )
+    where
+
+import           Control.Monad
+import           Control.Monad.Trans
+import           DDNS.DBInfo
+import           DDNS.Utils
+import           Data.Time.Clock
+import qualified Database.HDBC as RAW
+import qualified Database.HDBC.Sqlite3 as RAW
+import           Database.HaskellDB
+import           Database.HaskellDB.DBSpec
+import           Database.HaskellDB.HDBC.SQLite3
+import           OpenSSL.EVP.PKey
+import           OpenSSL.PEM
+import           OpenSSL.RSA
+import           OpenSSL.X509 as X509
+import           System.Console.Haskeline
+import           System.Directory
+import           System.FilePath
+import           System.IO
+import           System.Posix.Files
+import           System.Posix.Uname
+
+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 trim 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)
+
+type WithDB a = (Database -> IO a) -> IO a
+
+ensureWeHaveDB :: FilePath -> IO (WithDB a)
+ensureWeHaveDB lsdir
+    = do let dbFile = lsdir </> "server.db"
+         dbExist <- doesFileExist dbFile
+         unless dbExist $
+                do sqliteConnect dbFile $ \ db ->
+                       dbSpecToDatabase db dbinfo
+
+                   rawCon <- RAW.connectSqlite3 dbFile
+                   mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
+                   RAW.commit rawCon
+                   RAW.disconnect rawCon
+         return $ sqliteConnect dbFile