aboutsummaryrefslogtreecommitdiff
path: root/src/IRE
diff options
context:
space:
mode:
Diffstat (limited to 'src/IRE')
-rw-r--r--src/IRE/Application.hs19
-rw-r--r--src/IRE/Application/YOLO.hs10
-rw-r--r--src/IRE/Config.hs64
-rw-r--r--src/IRE/Logging.hs69
-rw-r--r--src/IRE/Server.hs71
5 files changed, 117 insertions, 116 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 11:12:20 +0000