module Main where
import Control.Monad
-import Control.Monad.Trans
+import DDNS.Client.MakeReq
import OpenSSL
-import OpenSSL.PEM
-import OpenSSL.RSA
-import OpenSSL.X509.Request
-import System.Console.Haskeline
import System.Console.ParseArgs
-import System.IO
-import System.Posix.Files
-import System.Posix.Uname
-
data Options
= Help
"makereq"
-> makeReq
_ -> usageError m ""
-
-
-makeReq :: IO ()
-makeReq
- = 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
-
- let pubFile = fqdn ++ ".pub"
- withFile pubFile WriteMode $ \ h ->
- writePublicKey key >>= hPutStr h
- putStrLn ("Wrote " ++ pubFile)
-
- let keyFile = fqdn ++ ".key"
- withFile keyFile WriteMode $ \ h ->
- writePKCS8PrivateKey key Nothing >>= hPutStr h
- setFileMode keyFile ownerReadMode
- putStrLn ("Wrote " ++ keyFile ++ " (with no encryption)")
-
- req <- newX509Req
- setVersion req 2
- setSubjectName req [("CN", fqdn)]
- setPublicKey req key
- signX509Req req key Nothing
- let reqFile = fqdn ++ ".req"
- withFile reqFile WriteMode $ \ h ->
- writeX509Req req ReqNewFormat >>= hPutStr h
- putStrLn ("Wrote " ++ reqFile)
- putStrLn ("Now send " ++ reqFile ++ " to the server operator and tell him/her to sign it.")
\ No newline at end of file
--- /dev/null
+module DDNS.Client.MakeReq
+ ( makeReq
+ )
+ where
+
+import Control.Monad
+import Control.Monad.Trans
+import DDNS.Utils
+import OpenSSL.PEM
+import OpenSSL.RSA
+import OpenSSL.X509.Request
+import System.Console.Haskeline
+import System.IO
+import System.Posix.Files
+import System.Posix.Uname
+
+makeReq :: IO ()
+makeReq
+ = do fqdn <- runInputT defaultSettings $
+ do defaultFqdn <- liftM uNodeName $ liftIO uname
+ fqdn <- getInputLine ("What's your FQDN? (default: " ++ defaultFqdn ++ "): ")
+ case trim fqdn of
+ Just s -> return s
+ _ -> return defaultFqdn
+
+ putStrLn "Generating RSA keypair..."
+ key <- generateRSAKey 1024 3 Nothing
+
+ let pubFile = fqdn ++ ".pub"
+ withFile pubFile WriteMode $ \ h ->
+ writePublicKey key >>= hPutStr h
+ putStrLn ("Wrote " ++ pubFile)
+
+ let keyFile = fqdn ++ ".key"
+ withFile keyFile WriteMode $ \ h ->
+ writePKCS8PrivateKey key Nothing >>= hPutStr h
+ setFileMode keyFile ownerReadMode
+ putStrLn ("Wrote " ++ keyFile ++ " (with no encryption)")
+
+ req <- newX509Req
+ setVersion req 2
+ setSubjectName req [("CN", fqdn)]
+ setPublicKey req key
+ signX509Req req key Nothing
+ let reqFile = fqdn ++ ".req"
+ withFile reqFile WriteMode $ \ h ->
+ writeX509Req req ReqNewFormat >>= hPutStr h
+ putStrLn ("Wrote " ++ reqFile)
+ putStrLn ("Now send " ++ reqFile ++ " to the server operator and tell him/her to sign it.")
--- /dev/null
+module DDNS.Server
+ ( ensureWeHaveKeypair
+ , ensureWeHaveDB
+ )
+ where
+
+import Control.Monad
+import Control.Monad.Trans
+import DDNS.DBInfo
+import DDNS.Utils
+import Data.Time.Clock
+import qualified Database.HDBC as RAW
+import qualified Database.HDBC.Sqlite3 as RAW
+import Database.HaskellDB
+import Database.HaskellDB.DBSpec
+import Database.HaskellDB.HDBC.SQLite3
+import OpenSSL.EVP.PKey
+import OpenSSL.PEM
+import OpenSSL.RSA
+import OpenSSL.X509 as X509
+import System.Console.Haskeline
+import System.Directory
+import System.FilePath
+import System.IO
+import System.Posix.Files
+import System.Posix.Uname
+
+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 trim 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)
+
+type WithDB a = (Database -> IO a) -> IO a
+
+ensureWeHaveDB :: FilePath -> IO (WithDB a)
+ensureWeHaveDB lsdir
+ = do let dbFile = lsdir </> "server.db"
+ dbExist <- doesFileExist dbFile
+ unless dbExist $
+ do sqliteConnect dbFile $ \ db ->
+ dbSpecToDatabase db dbinfo
+
+ rawCon <- RAW.connectSqlite3 dbFile
+ mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
+ RAW.commit rawCon
+ RAW.disconnect rawCon
+ return $ sqliteConnect dbFile
--- /dev/null
+module DDNS.Server.EditZone
+ ( editZone
+ )
+ where
+
+import Control.Monad
+import Control.Monad.Trans
+import DDNS.Utils
+import DDNS.Zone
+import Database.HaskellDB
+import System.Console.Haskeline
+
+editZone :: Database -> IO ()
+editZone db
+ = runInputT (setComplete (completeZoneName db) defaultSettings) $
+ do zoneNameStr <- getInputLine "Which zone do you want to edit (or create?): "
+ case trim zoneNameStr of
+ Just zoneNameStr'
+ -> liftIO $
+ do --let zone = read zoneNameStr'
+ fail zoneNameStr'
+ _ -> return ()
--- /dev/null
+module DDNS.Server.SignReq
+ ( signReq
+ )
+ where
+
+import Control.Monad
+import Control.Monad.Trans
+import DDNS.Utils
+import Data.List
+import Data.Time.Clock
+import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Verify
+import OpenSSL.PEM
+import OpenSSL.X509 as X509
+import OpenSSL.X509.Request as Req
+import System.Console.Haskeline
+import System.FilePath
+import System.IO
+
+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 trim 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 ()
--- /dev/null
+module DDNS.Utils
+ ( trim
+ )
+ where
+
+trim :: Maybe String -> Maybe String
+trim Nothing = Nothing
+trim (Just xs) = case trimTail $ trimHead xs of
+ "" -> Nothing
+ ys -> Just ys
+ where
+ trimHead [] = []
+ trimHead (' ':ys) = trimHead ys
+ trimHead ys = ys
+
+ trimTail = reverse . trimHead . reverse
--- /dev/null
+module DDNS.Zone
+ ( listZones
+ , completeZoneName
+ )
+ where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.List
+import Database.HaskellDB
+import qualified DDNS.DB.Zones as Zones
+import Network.DNS.Message
+import System.Console.Haskeline
+
+
+listZones :: Database -> IO [DomainName]
+listZones db
+ = do rows <- query db $ do t <- table Zones.zones
+ project (Zones.zone << t!Zones.zone)
+ return $ map (read . (!Zones.zone)) rows
+
+completeZoneName :: MonadIO m => Database -> CompletionFunc m
+completeZoneName db
+ = completeWord Nothing "" $ \ prefix ->
+ do zones <- liftM (map show) $ liftIO $ listZones db
+ return $ produceCands zones prefix
+ where
+ produceCands :: [String] -> String -> [Completion]
+ produceCands zones prefix
+ = let cands = filter (prefix `isPrefixOf`) zones
+ comps = map mkComp cands
+ in
+ comps
+
+ mkComp :: String -> Completion
+ mkComp zn
+ = Completion {
+ replacement = zn
+ , display = zn
+ , isFinished = True
+ }
-RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server --localstatedir . signreq
+RUN_COMMAND = ./dist/build/bbdns-server/bbdns-server --localstatedir . editzone
#RUN_COMMAND = ./dist/build/bbdns-client/bbdns-client makereq
include cabal-package.mk
module Main where
import Control.Monad
-import Control.Monad.Trans
+import DDNS.Server
+import DDNS.Server.EditZone
+import DDNS.Server.SignReq
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
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
--}
\ No newline at end of file
+ withDB <- ensureWeHaveDB lsdir
+
+ withDB $ \ db ->
+ case getRequiredArg m Command of
+ "signreq"
+ -> signReq key cert
+ "editzone"
+ -> editZone db
+ _ -> usageError m ""
Executable bbdns-server
Build-Depends:
- HDBC, HDBC-sqlite3, base, directory, filepath, haskelldb,
+ HDBC, HDBC-sqlite3, base, directory, dns, filepath, haskelldb,
haskelldb-hdbc-sqlite3, parseargs, time
Other-Modules:
DDNS.DB.Records
DDNS.DB.Zones
DDNS.DBInfo
+ DDNS.Server
+ DDNS.Server.EditZone
+ DDNS.Server.SignReq
+ DDNS.Utils
+ DDNS.Zone
Main-Is:
ServerMain.hs
unix
Other-Modules:
+ DDNS.Client.MakeReq
+ DDNS.Utils
System.Posix.Uname
Main-Is:
projects / blackboard-dns.git / commitdiff