diff options
author | Igor Pashev <pashev.igor@gmail.com> | 2017-08-03 21:26:33 +0300 |
---|---|---|
committer | Igor Pashev <pashev.igor@gmail.com> | 2017-08-03 21:32:06 +0300 |
commit | b1a599a6df4100ca1da6e778d1fdade3efe01451 (patch) | |
tree | 88e4e16c6f242cb92473d899cdfa0f10c84ddd4e | |
parent | 1c621db4b5b0d78ae6b2f79c71122c6cca2a0815 (diff) | |
download | ire-b1a599a6df4100ca1da6e778d1fdade3efe01451.tar.gz |
-rw-r--r-- | .hindent.yaml | 3 | ||||
-rw-r--r-- | src/IRE/Application.hs | 19 | ||||
-rw-r--r-- | src/IRE/Application/YOLO.hs | 10 | ||||
-rw-r--r-- | src/IRE/Config.hs | 64 | ||||
-rw-r--r-- | src/IRE/Logging.hs | 69 | ||||
-rw-r--r-- | src/IRE/Server.hs | 71 | ||||
-rw-r--r-- | src/Main.hs | 26 |
7 files changed, 134 insertions, 128 deletions
diff --git a/.hindent.yaml b/.hindent.yaml new file mode 100644 index 0000000..3dba089 --- /dev/null +++ b/.hindent.yaml @@ -0,0 +1,3 @@ +indent-size: 2 +line-length: 80 +force-trailing-newline: true diff --git a/src/IRE/Application.hs b/src/IRE/Application.hs index 530e4a4..bd8c796 100644 --- a/src/IRE/Application.hs +++ b/src/IRE/Application.hs @@ -1,16 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} -module IRE.Application ( - app -) where +module IRE.Application + ( app + ) where import Control.Monad.Trans (liftIO) import Network.Wai (Application) -import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->)) +import Network.Wai.Middleware.Static + ((>->), addBase, hasPrefix, staticPolicy) import Network.Wai.Parse (FileInfo(..)) import System.FilePath.Posix ((</>)) -import Web.Scotty ( ActionM, ScottyM, file, files, get, - json, middleware, post, scottyApp ) +import Web.Scotty + (ActionM, ScottyM, file, files, get, json, middleware, post, + scottyApp) import IRE.Application.YOLO (findItems) import IRE.YOLO (Detector) @@ -22,14 +24,11 @@ ire :: FilePath -> Detector -> ScottyM () ire rootDir net = do middleware $ staticPolicy (hasPrefix "static" >-> addBase rootDir) get "/" $ file (rootDir </> "webui.html") - post "/findItems" $ apiFindItems net - apiFindItems :: Detector -> ActionM () apiFindItems net = do fs <- files - let fc = head [ fileContent fi | (_, fi) <- fs ] + let fc = head [fileContent fi | (_, fi) <- fs] resp <- liftIO $ findItems net fc json resp - diff --git a/src/IRE/Application/YOLO.hs b/src/IRE/Application/YOLO.hs index 1d6ab37..6edace3 100644 --- a/src/IRE/Application/YOLO.hs +++ b/src/IRE/Application/YOLO.hs @@ -1,16 +1,14 @@ -module IRE.Application.YOLO ( - findItems -) where +module IRE.Application.YOLO + ( findItems + ) where import qualified Data.ByteString.Lazy as LBS -import IRE.YOLO (Detector, Item, detect) import qualified IRE.Logging as Log - +import IRE.YOLO (Detector, Item, detect) findItems :: Detector -> LBS.ByteString -> IO [Item] findItems d fc = do r <- detect d 0.3 0.3 (LBS.toStrict fc) Log.debug $ show r return r - diff --git a/src/IRE/Config.hs b/src/IRE/Config.hs index c2b90d6..08d89a9 100644 --- a/src/IRE/Config.hs +++ b/src/IRE/Config.hs @@ -1,51 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} -module IRE.Config ( - ConfigFile(..) -, YOLO(..) -, defaultConfig -) where +module IRE.Config + ( ConfigFile(..) + , YOLO(..) + , defaultConfig + ) where import Control.Applicative (empty) import Data.Aeson (FromJSON, parseJSON) -import Data.Yaml (Value(Object), (.:), (.:?), (.!=)) +import Data.Yaml (Value(Object), (.!=), (.:), (.:?)) +data ConfigFile = ConfigFile + { cfPort :: Int + , cfSocket :: Maybe FilePath + , cfYOLO :: YOLO + } deriving (Show) -data ConfigFile = ConfigFile { - cfPort :: Int -, cfSocket :: Maybe FilePath -, cfYOLO :: YOLO -} deriving (Show) - -data YOLO = YOLO { - yoloCfg :: FilePath -, yoloWeights :: FilePath -, yoloNames :: FilePath -} deriving (Show) - +data YOLO = YOLO + { yoloCfg :: FilePath + , yoloWeights :: FilePath + , yoloNames :: FilePath + } deriving (Show) defaultConfig :: ConfigFile -defaultConfig = ConfigFile { - cfPort = 8080 +defaultConfig = + ConfigFile + { cfPort = 8080 , cfSocket = Nothing - , cfYOLO = YOLO { - yoloCfg = "yolo.cfg" - , yoloWeights = "yolo.weights" - , yoloNames = "yolo.names" - } + , cfYOLO = + YOLO + { yoloCfg = "yolo.cfg" + , yoloWeights = "yolo.weights" + , yoloNames = "yolo.names" + } } instance FromJSON ConfigFile where - parseJSON (Object m) = ConfigFile <$> - m .:? "port" .!= cfPort defaultConfig - <*> m .:? "socket" .!= cfSocket defaultConfig - <*> m .:? "yolo" .!= cfYOLO defaultConfig + parseJSON (Object m) = + ConfigFile <$> m .:? "port" .!= cfPort defaultConfig <*> + m .:? "socket" .!= cfSocket defaultConfig <*> + m .:? "yolo" .!= cfYOLO defaultConfig parseJSON _ = empty instance FromJSON YOLO where - parseJSON (Object m) = YOLO <$> - m .: "cfg" - <*> m .: "weights" - <*> m .: "names" + parseJSON (Object m) = YOLO <$> m .: "cfg" <*> m .: "weights" <*> m .: "names" parseJSON _ = empty - diff --git a/src/IRE/Logging.hs b/src/IRE/Logging.hs index 3343f0f..006df70 100644 --- a/src/IRE/Logging.hs +++ b/src/IRE/Logging.hs @@ -1,12 +1,12 @@ -module IRE.Logging ( - LogLevel(..) -, debug -, error -, info -, level -, start -, warn -) where +module IRE.Logging + ( LogLevel(..) + , debug + , error + , info + , level + , start + , warn + ) where import Prelude hiding (error) @@ -15,13 +15,13 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Monad (forever, when) import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as JSON import Data.Char (toLower) import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Text as T import System.IO (hPrint, stderr) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) -import qualified Data.Aeson as JSON -import qualified Data.Text as T start :: LogLevel -> IO () start None = return () @@ -34,16 +34,15 @@ start lvl = do info :: String -> IO () info = send . Message Info -warn:: String -> IO () +warn :: String -> IO () warn = send . Message Warning -error:: String -> IO () +error :: String -> IO () error = send . Message Error debug :: String -> IO () debug = send . Message Debug - send :: Message -> IO () send msg@(Message l _) = do lvl <- level @@ -62,38 +61,46 @@ logLevel = unsafePerformIO (newIORef None) level :: IO LogLevel level = readIORef logLevel - -data LogLevel = None | Error | Warning | Info | Debug +data LogLevel + = None + | Error + | Warning + | Info + | Debug deriving (Enum, Ord, Eq) instance Show LogLevel where - show None = "NONE" - show Error = "ERROR" + show None = "NONE" + show Error = "ERROR" show Warning = "WARN" - show Info = "INFO" - show Debug = "DEBUG" + show Info = "INFO" + show Debug = "DEBUG" instance Read LogLevel where readsPrec _ s - | l == "none" = [ (None, "") ] - | l == "error" = [ (Error, "") ] - | l == "warn" = [ (Warning, "") ] - | l == "info" = [ (Info, "") ] - | l == "debug" = [ (Debug, "") ] - | otherwise = [ ] - where l = map toLower s + | l == "none" = [(None, "")] + | l == "error" = [(Error, "")] + | l == "warn" = [(Warning, "")] + | l == "info" = [(Info, "")] + | l == "debug" = [(Debug, "")] + | otherwise = [] + where + l = map toLower s instance ToJSON LogLevel where toJSON = JSON.String . T.pack . show instance FromJSON LogLevel where parseJSON (JSON.String s) = - maybe (fail $ "unknown log level: " ++ show s) return (readMaybe . T.unpack $ s) + maybe + (fail $ "unknown log level: " ++ show s) + return + (readMaybe . T.unpack $ s) parseJSON _ = empty - -data Message = Message LogLevel String +data Message = + Message LogLevel + String instance Show Message where show (Message lvl str) = show lvl ++ ": " ++ str - diff --git a/src/IRE/Server.hs b/src/IRE/Server.hs index 8dabc73..3a095a5 100644 --- a/src/IRE/Server.hs +++ b/src/IRE/Server.hs @@ -1,24 +1,28 @@ -module IRE.Server ( - server -) where +module IRE.Server + ( server + ) where -import Control.Exception.Base (throwIO, catch, bracket) -import Data.Yaml.Include (decodeFileEither) +import Control.Exception.Base (bracket, catch, throwIO) import Data.Bits ((.|.)) -import Network.Socket (socket, setSocketOption, bind, listen, close, - maxListenQueue, getSocketName, inet_addr, Family(AF_UNIX, AF_INET), - SocketType(Stream), SocketOption(ReuseAddr), Socket, SockAddr(..)) -import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket) +import Data.Yaml.Include (decodeFileEither) +import Network.Socket + (Family(AF_INET, AF_UNIX), SockAddr(..), Socket, + SocketOption(ReuseAddr), SocketType(Stream), bind, close, + getSocketName, inet_addr, listen, maxListenQueue, setSocketOption, + socket) +import Network.Wai.Handler.Warp + (Port, defaultSettings, runSettingsSocket) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) -import System.Posix.Files ( fileExist, groupReadMode, groupWriteMode, - ownerReadMode, ownerWriteMode, removeLink, setFileMode, socketMode ) +import System.Posix.Files + (fileExist, groupReadMode, groupWriteMode, ownerReadMode, + ownerWriteMode, removeLink, setFileMode, socketMode) import IRE.Application (app) import IRE.Config (ConfigFile(..), defaultConfig) -import IRE.YOLO (newDetector) import qualified IRE.Logging as Log +import IRE.YOLO (newDetector) type Listen = Either Port FilePath @@ -29,37 +33,36 @@ server rootDir configFile = do Log.start Log.Debug let socketSpec = case cfSocket cf of - Just p -> Right p + Just p -> Right p Nothing -> Left $ cfPort cf bracket (createSocket socketSpec) closeSocket - ( \sock -> do - listen sock maxListenQueue - runSettingsSocket defaultSettings sock =<< app rootDir net) - + (\sock -> do + listen sock maxListenQueue + runSettingsSocket defaultSettings sock =<< app rootDir net) readConfigFile :: FilePath -> IO ConfigFile readConfigFile f = do e <- fileExist f - if e then do - r <- decodeFileEither f - case r of - Left ex -> do - hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show ex - exitFailure - Right cf -> return cf - else return defaultConfig - + if e + then do + r <- decodeFileEither f + case r of + Left ex -> do + hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show ex + exitFailure + Right cf -> return cf + else return defaultConfig createSocket :: Listen -> IO Socket createSocket (Right 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 Log.info $ "Listening on UNIX socket `" ++ path ++ "'" return sock createSocket (Left port) = do @@ -70,7 +73,6 @@ createSocket (Left port) = do Log.info $ "Listening on localhost:" ++ show port return sock - closeSocket :: Socket -> IO () closeSocket sock = do name <- getSocketName sock @@ -79,10 +81,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 diff --git a/src/Main.hs b/src/Main.hs index 5070d8d..6527584 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,14 +1,15 @@ {-# LANGUAGE QuasiQuotes #-} -module Main ( - main -) where + +module Main + ( main + ) where import Data.Maybe (fromJust) import Data.Version (showVersion) import Paths_ire (getDataDir, version) -- from cabal +import qualified System.Console.Docopt.NoTH as O import System.Environment (getArgs) import Text.InterpolatedString.Perl6 (qc) -import qualified System.Console.Docopt.NoTH as O import IRE.Server (server) @@ -16,8 +17,10 @@ usage :: IO String usage = do dataDir <- getDataDir return $ - "IRE " ++ showVersion version ++ - " - Watching you!" ++ [qc| + "IRE " ++ + showVersion version ++ + " - Watching you!" ++ + [qc| Usage: ire [options] @@ -39,9 +42,8 @@ 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 configFile = fromJust . O.getArg args $ O.longOption "config" - rootDir = fromJust . O.getArg args $ O.longOption "rootdir" - server rootDir configFile - + then putStrLn $ O.usage doco + else do + let configFile = fromJust . O.getArg args $ O.longOption "config" + rootDir = fromJust . O.getArg args $ O.longOption "rootdir" + server rootDir configFile |