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                            fqdn        <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ")
  42                            case trim fqdn of
  43                              Just s -> return s
  44                              _      -> return defaultFqdn
  45
  46                 putStrLn "Generating RSA keypair..."
  47                 key <- generateRSAKey 1024 3 Nothing
  48                 withFile keyFile WriteMode $ \ h ->
  49                     writePKCS8PrivateKey key Nothing >>= hPutStr h
  50                 setFileMode keyFile ownerReadMode
  51                 putStrLn ("Wrote " ++ keyFile)
  52
  53                 cert <- newX509
  54                 X509.setVersion      cert 2
  55                 X509.setSerialNumber cert 1
  56                 X509.setIssuerName   cert [("CN", fqdn)]
  57                 X509.setSubjectName  cert [("CN", fqdn)]
  58                 X509.setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
  59                 X509.setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
  60                 X509.setPublicKey    cert key
  61                 X509.signX509        cert key Nothing
  62                 withFile certFile WriteMode $ \ h ->
  63                     writeX509 cert >>= hPutStr h
  64                 putStrLn ("Wrote " ++ certFile)
  65
  66                 return (fromKeyPair key, cert)
  67
  68 type WithDB a = (Database -> IO a) -> IO a
  69
  70 ensureWeHaveDB :: FilePath -> IO (WithDB a)
  71 ensureWeHaveDB lsdir
  72     = do let dbFile = lsdir </> "server.db"
  73          dbExist <- doesFileExist dbFile
  74          unless dbExist $
  75                 do sqliteConnect dbFile $ \ db ->
  76                        dbSpecToDatabase db dbinfo
  77
  78                    rawCon <- RAW.connectSqlite3 dbFile
  79                    mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
  80                    RAW.commit rawCon
  81                    RAW.disconnect rawCon
  82          return $ sqliteConnect dbFile