ServerMain.hs

   1 {-# LANGUAGE CPP #-}
   2 module Main where
   3
   4 import           Control.Monad
   5 import           Control.Monad.Trans
   6 import           Data.List
   7 import           Data.Time.Clock
   8 {-
   9 import           DDNS.DBInfo
  10 import qualified Database.HDBC as RAW
  11 import qualified Database.HDBC.Sqlite3 as RAW
  12 import           Database.HaskellDB.DBSpec
  13 import           Database.HaskellDB.HDBC.SQLite3
  14 -}
  15 import           OpenSSL
  16 import           OpenSSL.EVP.PKey
  17 import           OpenSSL.EVP.Verify
  18 import           OpenSSL.PEM
  19 import           OpenSSL.RSA
  20 import           OpenSSL.X509 as X509
  21 import           OpenSSL.X509.Request as Req
  22 import           System.Console.Haskeline
  23 import           System.Console.ParseArgs
  24 import           System.Directory
  25 import           System.FilePath
  26 import           System.IO
  27 import           System.Posix.Files
  28 import           System.Posix.Uname
  29
  30 data Options
  31     = Help
  32     | LSDir
  33     | DNSPort
  34     | HTTPSPort
  35     | AllowTransfer
  36     | Command
  37     deriving (Show, Eq, Ord)
  38
  39 arginfo :: [Arg Options]
  40 arginfo = [ Arg {
  41               argIndex = Help
  42             , argAbbr  = Just 'h'
  43             , argName  = Just "help"
  44             , argData  = Nothing
  45             , argDesc  = "print this help."
  46             }
  47           , Arg {
  48               argIndex = LSDir
  49             , argAbbr  = Just 'd'
  50             , argName  = Just "localstatedir"
  51             -- LOCALSTATEDIR will be replaced by CPP
  52             , argData  = argDataDefaulted "DIR" ArgtypeString LOCALSTATEDIR
  53             , argDesc  = "specify the local state directory (def: " ++ LOCALSTATEDIR ++ ")."
  54             }
  55           , Arg {
  56               argIndex = DNSPort
  57             , argAbbr  = Just 'p'
  58             , argName  = Just "dns-port"
  59             , argData  = argDataDefaulted "PORT" ArgtypeString "53"
  60             , argDesc  = "port to listen for DNS packets (default: 53)."
  61             }
  62           , Arg {
  63               argIndex = HTTPSPort
  64             , argAbbr  = Just 'P'
  65             , argName  = Just "https-port"
  66             , argData  = argDataDefaulted "PORT" ArgtypeString "443"
  67             , argDesc  = "port to listen for HTTPS connections (def: 443)."
  68             }
  69           , Arg {
  70               argIndex = AllowTransfer
  71             , argAbbr  = Just 'a'
  72             , argName  = Just "allow-transfer"
  73             , argData  = Nothing
  74             , argDesc  = "accept AXFR requests."
  75             }
  76           , Arg {
  77               argIndex = Command
  78             , argAbbr  = Nothing
  79             , argName  = Nothing
  80             , argData  = argDataDefaulted "COMMAND" ArgtypeString "daemon"
  81             , argDesc  = "command to the server (default: \"daemon\")."
  82             }
  83           ]
  84
  85 main :: IO ()
  86 main = withOpenSSL $
  87        do m <- parseArgsIO ArgsComplete arginfo
  88           when (gotArg m Help)
  89                    $ usageError m ""
  90
  91           let lsdir = getRequiredArg m LSDir
  92           (key, cert) <- ensureWeHaveKeypair lsdir
  93
  94           case getRequiredArg m Command of
  95             "signreq"
  96                 -> signReq key cert
  97             _   -> usageError m ""
  98
  99 ensureWeHaveKeypair :: FilePath -> IO (SomeKeyPair, X509)
 100 ensureWeHaveKeypair lsdir
 101     = do let keyFile  = lsdir </> "server.key"
 102              certFile = lsdir </> "server.cert"
 103          keyExi <- doesFileExist keyFile
 104          cerExi <- doesFileExist certFile
 105          if keyExi && cerExi then
 106              do key  <- flip readPrivateKey PwNone =<< readFile keyFile
 107                 cert <- readX509 =<< readFile certFile
 108                 return (key, cert)
 109            else
 110              do fqdn <- runInputT defaultSettings $
 111                         do defaultFqdn <- liftM uNodeName $ liftIO uname
 112                            fqdn        <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ")
 113                            case fqdn of
 114                              Just s@(_:_) -> return s
 115                              _            -> return defaultFqdn
 116
 117                 putStrLn "Generating RSA keypair..."
 118                 key <- generateRSAKey 1024 3 Nothing
 119                 withFile keyFile WriteMode $ \ h ->
 120                     writePKCS8PrivateKey key Nothing >>= hPutStr h
 121                 setFileMode keyFile ownerReadMode
 122                 putStrLn ("Wrote " ++ keyFile)
 123
 124                 cert <- newX509
 125                 X509.setVersion      cert 2
 126                 X509.setSerialNumber cert 1
 127                 X509.setIssuerName   cert [("CN", fqdn)]
 128                 X509.setSubjectName  cert [("CN", fqdn)]
 129                 X509.setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
 130                 X509.setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
 131                 X509.setPublicKey    cert key
 132                 X509.signX509        cert key Nothing
 133                 withFile certFile WriteMode $ \ h ->
 134                     writeX509 cert >>= hPutStr h
 135                 putStrLn ("Wrote " ++ certFile)
 136
 137                 return (fromKeyPair key, cert)
 138
 139 signReq :: KeyPair k => k -> X509 -> IO ()
 140 signReq sKey sCert
 141     = runInputT (setComplete completeFilename defaultSettings) $
 142       do file <- getInputLine "Which X.509 request do you want to sign?: "
 143          case file of
 144            Just file'@(_:_)
 145                -> liftIO $
 146                   do req <- readX509Req =<< readFile file'
 147                      key <- Req.getPublicKey req
 148                      vst <- verifyX509Req req key
 149                      unless (vst == VerifySuccess)
 150                          $ fail "Invalid X.509 request"
 151
 152                      cert <- makeX509FromReq req sCert
 153                      setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable.
 154                      setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
 155                      setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
 156                      signX509        cert sKey Nothing
 157
 158                      let certFile = file' `replaceExtension` ".cert"
 159                      withFile certFile WriteMode $ \ h ->
 160                          writeX509 cert >>= hPutStr h
 161                      putStrLn ("Wrote " ++ certFile)
 162
 163                      Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False
 164                      putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".")
 165            _   -> return ()
 166
 167 {-
 168 main = do sqliteConnect "ddns.db" $ \ db ->
 169               dbSpecToDatabase db dbinfo
 170
 171           rawCon <- RAW.connectSqlite3 "ddns.db"
 172           mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
 173           RAW.commit rawCon
 174           RAW.disconnect rawCon
 175 -}