]> gitweb @ CieloNegro.org - blackboard-dns.git/blob - DDNS/Server.hs
aedeadd1889ab6d5649c666f8ec1d90438b78593
[blackboard-dns.git] / 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