{-# LANGUAGE CPP #-}
module Main where

import           Control.Monad
import           Control.Monad.Trans
import           Data.List
import           Data.Time.Clock
{-
import           DDNS.DBInfo
import qualified Database.HDBC as RAW
import qualified Database.HDBC.Sqlite3 as RAW
import           Database.HaskellDB.DBSpec
import           Database.HaskellDB.HDBC.SQLite3
-}
import           OpenSSL
import           OpenSSL.EVP.PKey
import           OpenSSL.EVP.Verify
import           OpenSSL.PEM
import           OpenSSL.RSA
import           OpenSSL.X509 as X509
import           OpenSSL.X509.Request as Req
import           System.Console.Haskeline
import           System.Console.ParseArgs
import           System.Directory
import           System.FilePath
import           System.IO
import           System.Posix.Files
import           System.Posix.Uname

data Options
    = Help
    | LSDir
    | DNSPort
    | HTTPSPort
    | AllowTransfer
    | Command
    deriving (Show, Eq, Ord)

arginfo :: [Arg Options]
arginfo = [ Arg {
              argIndex = Help
            , argAbbr  = Just 'h'
            , argName  = Just "help"
            , argData  = Nothing
            , argDesc  = "print this help."
            }
          , Arg {
              argIndex = LSDir
            , argAbbr  = Just 'd'
            , argName  = Just "localstatedir"
            -- LOCALSTATEDIR will be replaced by CPP
            , argData  = argDataDefaulted "DIR" ArgtypeString LOCALSTATEDIR
            , argDesc  = "specify the local state directory (def: " ++ LOCALSTATEDIR ++ ")."
            }
          , Arg {
              argIndex = DNSPort
            , argAbbr  = Just 'p'
            , argName  = Just "dns-port"
            , argData  = argDataDefaulted "PORT" ArgtypeString "53"
            , argDesc  = "port to listen for DNS packets (default: 53)."
            }
          , Arg {
              argIndex = HTTPSPort
            , argAbbr  = Just 'P'
            , argName  = Just "https-port"
            , argData  = argDataDefaulted "PORT" ArgtypeString "443"
            , argDesc  = "port to listen for HTTPS connections (def: 443)."
            }
          , Arg {
              argIndex = AllowTransfer
            , argAbbr  = Just 'a'
            , argName  = Just "allow-transfer"
            , argData  = Nothing
            , argDesc  = "accept AXFR requests."
            }
          , Arg {
              argIndex = Command
            , argAbbr  = Nothing
            , argName  = Nothing
            , argData  = argDataDefaulted "COMMAND" ArgtypeString "daemon"
            , argDesc  = "command to the server (default: \"daemon\")."
            }
          ]

main :: IO ()
main = withOpenSSL $
       do m <- parseArgsIO ArgsComplete arginfo
          when (gotArg m Help)
                   $ usageError m ""

          let lsdir = getRequiredArg m LSDir
          (key, cert) <- ensureWeHaveKeypair lsdir

          case getRequiredArg m Command of
            "signreq"
                -> signReq key cert
            _   -> usageError m ""

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 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)

signReq :: KeyPair k => k -> X509 -> IO ()
signReq sKey sCert
    = runInputT (setComplete completeFilename defaultSettings) $
      do file <- getInputLine "Which X.509 request do you want to sign?: "
         case file of
           Just file'@(_:_)
               -> liftIO $
                  do req <- readX509Req =<< readFile file'
                     key <- Req.getPublicKey req
                     vst <- verifyX509Req req key
                     unless (vst == VerifySuccess)
                         $ fail "Invalid X.509 request"

                     cert <- makeX509FromReq req sCert
                     setSerialNumber cert 1 -- FIXME: This nasty behavior makes revocation-list unusable.
                     setNotBefore    cert =<< liftM (addUTCTime (-1)) getCurrentTime
                     setNotAfter     cert =<< liftM (addUTCTime (20 * 365 * 24 * 60 * 60)) getCurrentTime
                     signX509        cert sKey Nothing

                     let certFile = file' `replaceExtension` ".cert"
                     withFile certFile WriteMode $ \ h ->
                         writeX509 cert >>= hPutStr h
                     putStrLn ("Wrote " ++ certFile)

                     Just (_, fqdn) <- liftM (find ((== "CN") . fst)) $ X509.getSubjectName cert False
                     putStrLn ("Now send " ++ certFile ++ " back to " ++ fqdn ++ ".")
           _   -> return ()

{-
main = do sqliteConnect "ddns.db" $ \ db ->
              dbSpecToDatabase db dbinfo

          rawCon <- RAW.connectSqlite3 "ddns.db"
          mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
          RAW.commit rawCon
          RAW.disconnect rawCon
-}