Use optparse-applicative instead of docopt

3 files changed, 157 insertions, 102 deletions

diff --git a/juandelacosa.cabal b/juandelacosa.cabal
index 8dcd03d..02dc050 100644
--- a/juandelacosa.cabal
+++ b/juandelacosa.cabal
@@ -39,15 +39,14 @@ executable juandelacosa
       , base64-bytestring        >= 1.0
       , bytestring               >= 0.10
       , data-default-class
-      , docopt                   >= 0.7
       , entropy                  >= 0.3
       , fast-logger
       , http-types               >= 0.9
-      , interpolatedstring-perl6 >= 1.0
       , mtl                      >= 2.2
       , mysql                    >= 0.1
       , mysql-simple             >= 0.2
       , network                  >= 2.6
+      , optparse-applicative     >= 0.13.0.0
       , resource-pool            >= 0.2
       , scotty                   >= 0.10
       , text                     >= 1.2
diff --git a/src/Main.hs b/src/Main.hs
index 7e72a0a..45a6a0a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,73 +1,113 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Main (
-  main
-) where
+module Main
+  ( main
+  ) where
 
 import Data.ByteString.Char8 (pack)
-import Data.Maybe (fromJust)
 import Data.Version (showVersion)
 import Database.MySQL.Base (ConnectInfo(..))
 import Database.MySQL.Base.Types (Option(ReadDefaultFile, ReadDefaultGroup))
 import Paths_juandelacosa (getDataDir, version) -- from cabal
-import System.Environment (getArgs)
-import Text.InterpolatedString.Perl6 (qc)
-import qualified System.Console.Docopt.NoTH as O
-
-import Server (server)
-
-usage :: IO String
-usage = do
-  dataDir <- getDataDir
-  return $
-    "juandelacosa " ++ showVersion version
-    ++ " manage MariaDB user and roles" ++ [qc|
+import System.IO.Unsafe (unsafePerformIO)
 
-Usage:
-  juandelacosa [options]
+import Options.Applicative
+  ( Parser
+  , (<**>)
+  , (<|>)
+  , auto
+  , execParser
+  , fullDesc
+  , header
+  , help
+  , helper
+  , info
+  , long
+  , metavar
+  , option
+  , optional
+  , short
+  , showDefault
+  , strOption
+  , value
+  )
 
-Options:
-  -f, --file=MYCNF         Read this MySQL client config file
-  -g, --group=GROUP        Read this options group in the above file [default: client]
+import Server (Listen(Port, Socket), server)
 
-  -d, --datadir=DIR        Data directory including static files [default: {dataDir}]
+data Config =
+  Config
+    { file :: Maybe FilePath
+    , group :: String
+    , datadir :: FilePath
+    , listen :: Listen
+    }
 
-  -s, --socket=SOCK        Listen on this UNIX-socket [default: /tmp/juandelacosa.sock]
-  -p, --port=PORT          Instead of UNIX-socket, listen on this TCP port (localhost)
+parseListen :: Parser Listen
+parseListen = port <|> socket
+  where
+    port =
+      Port <$>
+      option
+        auto
+        (long "port" <>
+         short 'p' <>
+         metavar "INT" <> help "listen on this TCP port (localhost only)")
+    socket =
+      Socket <$>
+      option
+        auto
+        (long "socket" <>
+         short 's' <>
+         metavar "PATH" <>
+         value "/tmp/juandelacosa.sock" <>
+         showDefault <> help "Listen on this UNIX-socket")
 
-  -h, --help               Show this message
+{-# NOINLINE dataDir #-}
+dataDir :: FilePath
+dataDir = unsafePerformIO getDataDir
 
-|]
+parseConfig :: Parser Config
+parseConfig =
+  Config <$>
+  optional
+    (strOption
+       (long "file" <>
+        short 'f' <> metavar "FILE" <> help "Read this MySQL client config file")) <*>
+  strOption
+    (long "group" <>
+     short 'g' <>
+     metavar "STRING" <>
+     value "client" <>
+     showDefault <> help "Read this options group in the above file") <*>
+  strOption
+    (long "datadir" <>
+     short 'd' <>
+     metavar "DIR" <>
+     value dataDir <>
+     showDefault <> help "Data directory including static files") <*>
+  parseListen
 
-main :: IO()
-main = do
-  doco <- O.parseUsageOrExit =<< usage
-  args <- O.parseArgsOrExit doco =<< getArgs
-  if args `O.isPresent` O.longOption "help"
-  then putStrLn $ O.usage doco
-  else do
-    let
-      file = O.getArg args $ O.longOption "file"
-      group = fromJust $ O.getArg args $ O.longOption "group"
-      port = O.getArg args $ O.longOption "port"
-      socket = fromJust $ O.getArg args $ O.longOption "socket"
-      datadir = fromJust $ O.getArg args $ O.longOption "datadir"
-    -- XXX: mysql package maps empty strings to NULL
-    -- which is what we need, see documentation for mysql_real_connect()
-    let myInfo = ConnectInfo {
-        connectDatabase = "",
-        connectHost     = "",
-        connectOptions  = case file of
-                          Nothing -> []
-                          Just f -> [ ReadDefaultFile f, ReadDefaultGroup (pack group) ],
-        connectPassword = "",
-        connectPath     = "",
-        connectPort     = 0,
-        connectSSL      = Nothing,
-        connectUser     = ""
-      }
-    let listen = case port of
-          Nothing -> Right socket
-          Just p -> Left $ read p
-    server listen myInfo datadir
+run :: Config -> IO ()
+run cfg = do
+  let myInfo =
+        ConnectInfo
+          { connectDatabase = ""
+          , connectHost = ""
+          , connectOptions =
+              case file cfg of
+                Nothing -> []
+                Just f ->
+                  [ReadDefaultFile f, ReadDefaultGroup (pack $ group cfg)]
+          , connectPassword = ""
+          , connectPath = ""
+          , connectPort = 0
+          , connectSSL = Nothing
+          , connectUser = ""
+          }
+  server (listen cfg) myInfo (datadir cfg)
 
+main :: IO ()
+main = run =<< execParser opts
+  where
+    opts = info (parseConfig <**> helper) (fullDesc <> header desc)
+    desc =
+      "juandelacosa " ++
+      showVersion version ++ " - manage MariaDB user and roles"
diff --git a/src/Server.hs b/src/Server.hs
index 10d4328..14d7579 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -1,60 +1,78 @@
 module Server
-(
-  server
-) where
+  ( Listen(..)
+  , server
+  ) where
 
-import Control.Exception.Base (throwIO, catch, bracket)
+import Control.Exception.Base (bracket, catch, throwIO)
 import Data.Bits ((.|.))
 import Data.Pool (createPool, destroyAllResources)
 import Database.MySQL.Base (ConnectInfo)
-import Network.Socket (socket, setSocketOption, bind, listen, close,
-  maxListenQueue, getSocketName, inet_addr, Family(AF_UNIX, AF_INET),
-  SocketType(Stream), SocketOption(ReuseAddr), Socket, SockAddr(SockAddrUnix,
-  SockAddrInet))
+import qualified Database.MySQL.Simple as MySQL
+import Network.Socket
+  ( Family(AF_INET, AF_UNIX)
+  , SockAddr(SockAddrInet, SockAddrUnix)
+  , Socket
+  , SocketOption(ReuseAddr)
+  , SocketType(Stream)
+  , bind
+  , close
+  , getSocketName
+  , inet_addr
+  , listen
+  , maxListenQueue
+  , setSocketOption
+  , socket
+  )
 import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket)
 import System.IO (hPutStrLn, stderr)
 import System.IO.Error (isDoesNotExistError)
-import System.Posix.Files (removeLink, setFileMode, socketMode, ownerReadMode,
-  ownerWriteMode, groupReadMode, groupWriteMode)
-import qualified Database.MySQL.Simple as MySQL
+import System.Posix.Files
+  ( groupReadMode
+  , groupWriteMode
+  , ownerReadMode
+  , ownerWriteMode
+  , removeLink
+  , setFileMode
+  , socketMode
+  )
 
 import Application (app)
 
-type Listen = Either Port FilePath
-
+data Listen
+  = Socket FilePath
+  | Port Int
 
 server :: Listen -> ConnectInfo -> FilePath -> IO ()
 server socketSpec mysqlConnInfo dataDir =
   bracket
-    ( do
-      sock <- createSocket socketSpec
-      mysql <- createPool
-                (MySQL.connect mysqlConnInfo)
-                MySQL.close
-                1 -- stripes
-                60 -- keep alive (seconds)
-                10 -- max connections
-      return (sock, mysql) )
-    ( \(sock, mysql) -> do
-      closeSocket sock
-      destroyAllResources mysql )
-    ( \(sock, mysql) -> do
-      listen sock maxListenQueue
-      hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'"
-      runSettingsSocket defaultSettings sock =<< app mysql dataDir)
-
+    (do sock <- createSocket socketSpec
+        mysql <-
+          createPool
+            (MySQL.connect mysqlConnInfo)
+            MySQL.close
+            1 -- stripes
+            60 -- keep alive (seconds)
+            10 -- max connections
+        return (sock, mysql))
+    (\(sock, mysql) -> do
+       closeSocket sock
+       destroyAllResources mysql)
+    (\(sock, mysql) -> do
+       listen sock maxListenQueue
+       hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'"
+       runSettingsSocket defaultSettings sock =<< app mysql dataDir)
 
 createSocket :: Listen -> IO Socket
-createSocket (Right path) = do
+createSocket (Socket path) = do
   removeIfExists path
   sock <- socket AF_UNIX Stream 0
   bind sock $ SockAddrUnix path
-  setFileMode path $ socketMode
-                  .|. ownerWriteMode .|. ownerReadMode
-                  .|. groupWriteMode .|. groupReadMode
+  setFileMode path $
+    socketMode .|. ownerWriteMode .|. ownerReadMode .|. groupWriteMode .|.
+    groupReadMode
   hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'"
   return sock
-createSocket (Left port) = do
+createSocket (Port port) = do
   sock <- socket AF_INET Stream 0
   setSocketOption sock ReuseAddr 1
   addr <- inet_addr "127.0.0.1"
@@ -62,7 +80,6 @@ createSocket (Left port) = do
   hPutStrLn stderr $ "Listening on localhost:" ++ show port
   return sock
 
-
 closeSocket :: Socket -> IO ()
 closeSocket sock = do
   name <- getSocketName sock
@@ -71,10 +88,9 @@ closeSocket sock = do
     SockAddrUnix path -> removeIfExists path
     _ -> return ()
 
-
 removeIfExists :: FilePath -> IO ()
 removeIfExists fileName = removeLink fileName `catch` handleExists
-  where handleExists e
-          | isDoesNotExistError e = return ()
-          | otherwise = throwIO e
-
+  where
+    handleExists e
+      | isDoesNotExistError e = return ()
+      | otherwise = throwIO e