DDNS/Server.hs

   1 module DDNS.Server
   2     ( ensureWeHaveKeypair
   3     , ensureWeHaveDB
   4     )
   5     where
   6
   7 import           Control.Monad
   8 import           Control.Monad.Trans
   9 import           DDNS.DBInfo
  10 import           DDNS.Utils
  11 import           Data.Time.Clock
  12 import qualified Database.HDBC as RAW
  13 import qualified Database.HDBC.Sqlite3 as RAW
  14 import           Database.HaskellDB
  15 import           Database.HaskellDB.DBSpec
  16 import           Database.HaskellDB.HDBC.SQLite3
  17 import           OpenSSL.EVP.PKey
  18 import           OpenSSL.PEM
  19 import           OpenSSL.RSA
  20 import           OpenSSL.X509 as X509
  21 import           System.Console.Haskeline
  22 import           System.Directory
  23 import           System.FilePath
  24 import           System.IO
  25 import           System.Posix.Files
  26 import           System.Posix.Uname
  27
  28 ensureWeHaveKeypair :: FilePath -> IO (SomeKeyPair, X509)
  29 ensureWeHaveKeypair lsdir
  30     = do let keyFile  = lsdir </> "server.key"
  31              certFile = lsdir </> "server.cert"
  32          keyExi <- doesFileExist keyFile
  33          cerExi <- doesFileExist certFile
  34          if keyExi && cerExi then
  35              do key  <- flip readPrivateKey PwNone =<< readFile keyFile
  36                 cert <- readX509 =<< readFile certFile
  37                 return (key, cert)
  38            else
  39              do fqdn <- runInputT defaultSettings $
  40                         do defaultFqdn <- liftM uNodeName $ liftIO uname
  41                            getInputLineWithDefault
  42                                ("What is the server FQDN? (default: " ++ defaultFqdn ++ "): ")
  43                                defaultFqdn
  44
  45                 putStrLn "Generating RSA keypair..."
  46                 key <- generateRSAKey 1024 3 Nothing
  47                 withFile keyFile WriteMode $ \ h ->
  48                     writePKCS8PrivateKey key Nothing >>= hPutStr h
  49                 setFileMode keyFile ownerReadMode
  50                 putStrLn ("Wrote " ++ keyFile)
  51
  52                 cert <- newX509
  53                 X509.setVersion      cert 2
  54                 X509.setSerialNumber cert 1
  55                 X509.setIssuerName   cert [("CN", fqdn)]
  56                 X509.setSubjectName  cert [("CN", fqdn)]
  57                 X509.setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
  58                 X509.setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
  59                 X509.setPublicKey    cert key
  60                 X509.signX509        cert key Nothing
  61                 withFile certFile WriteMode $ \ h ->
  62                     writeX509 cert >>= hPutStr h
  63                 putStrLn ("Wrote " ++ certFile)
  64
  65                 return (fromKeyPair key, cert)
  66
  67 type WithDB a = (Database -> IO a) -> IO a
  68
  69 ensureWeHaveDB :: FilePath -> IO (WithDB a)
  70 ensureWeHaveDB lsdir
  71     = do let dbFile = lsdir </> "server.db"
  72          dbExist <- doesFileExist dbFile
  73          unless dbExist $
  74                 do sqliteConnect dbFile $ \ db ->
  75                        dbSpecToDatabase db dbinfo
  76
  77                    rawCon <- RAW.connectSqlite3 dbFile
  78                    mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
  79                    RAW.commit rawCon
  80                    RAW.disconnect rawCon
  81          return $ sqliteConnect dbFile