diff --git a/app/Main.hs b/app/Main.hs index ad0d861..b6db1f7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ import Data.Pool (Pool, defaultPoolConfig, newPool, withResource) import Data.Proxy (Proxy (..)) import Data.Time (Day, toGregorian) import Network.HTTP.Media ((//), (/:)) -import Network.HTTP.Types (status200) +import Network.HTTP.Types (Status (..), status200) import Servant ( Accept (..) , Capture @@ -32,7 +32,7 @@ import Text.Printf (printf) import qualified Data.ByteString.Char8 as BS8 import qualified Data.Text as Text import qualified Database.PostgreSQL.Opium as Opium -import Network.Wai (responseFile) +import Network.Wai (Request (..), responseFile) import qualified Network.Wai.Handler.Warp as Warp import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -41,6 +41,7 @@ import Yore.DB (DayFile (..)) import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) import qualified Yore.DB as DB +import qualified Yore.Log as Log instance Exception Opium.ConnectionError @@ -55,10 +56,20 @@ main = do Opium.close 10 maxResources - Warp.run 3000 $ serve (Proxy :: Proxy API) $ server connPool + Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server connPool where unsafeConnect s = either throwIO pure =<< Opium.connect s + settings = Warp.setLogger logger Warp.defaultSettings + + logger req status _ = do + Log.info $ + printf + "%d %s %s" + (statusCode status) + (BS8.unpack $ requestMethod req) + (BS8.unpack $ rawPathInfo req <> rawQueryString req) + type API = Get '[HTML] RootModel :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel diff --git a/src/Yore/Log.hs b/src/Yore/Log.hs new file mode 100644 index 0000000..997f95b --- /dev/null +++ b/src/Yore/Log.hs @@ -0,0 +1,19 @@ +module Yore.Log (info) where + +import Data.Time (getZonedTime) +import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack) +import Text.Printf (printf) + +info :: (HasCallStack) => String -> IO () +info = doLog "INF" + +doLog :: (HasCallStack) => String -> String -> IO () +doLog level msg = do + now <- getZonedTime + let location = getLocation $ getCallStack callStack + printf "(%s) (%s) (%s) %s\n" (show now) location level msg + where + getLocation :: [(String, SrcLoc)] -> String + -- First entry is always a function from this module, skip it + getLocation (_ : (_, srcLoc) : _) = printf "%s:%d" (srcLocFile srcLoc) (srcLocStartLine srcLoc) + getLocation _ = "" diff --git a/yore.cabal b/yore.cabal index 3158e4a..d29a6d0 100644 --- a/yore.cabal +++ b/yore.cabal @@ -36,6 +36,7 @@ library Yore.DB , Yore.Download , Yore.Index + , Yore.Log , Yore.Repl , Yore.Scrape , Yore.Time