Small web service using scotty

Question

I'm writing a small tool that allows to manually protocol dial-in-actions. That means a user can say he dials in to a site or he dials out of a site. (What this means is not important for the sake of this software.) These action are stored as plain JSON text with automatic backups. The communication with the front end is achieved by providing a restful API that enables the frontend to post new entries and receive the current state. This state is simply who is currently dials in where. The frontend is written in Elm, the backend in Haskell.

Since I'm relatively new to Haskell, it would be cool if you could give me some pointers on how to improve my code.

Main.hs:

{-
    Main.hs
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Main where

import Control.Applicative
import Control.Arrow
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Loops
import Control.Monad.Trans (liftIO)
import Data.Aeson.Types
import Data.Function
import Data.List
import Data.Maybe
import Data.Text.Lazy (unpack, pack)
import Data.Time.Clock.POSIX
import Data.Time.Format (formatTime, FormatTime)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as PrettyAeson
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as Map
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import System.Locale
import Web.Scotty

import Entry

-- | Forward application.
(|>) :: a -> (a -> b) -> b
(|>) a b = b a
infixl 0 |>

-- | Read command line parameters and run webserver.
main :: IO ()
main = do
    args <- getArgs
    let (port, dbFilePath) = getParams args
    scottyMain port dbFilePath

-- | Parse command line.
getParams :: [String] -> (Int, FilePath)
getParams (port:dbFilePath:_) =
    (read port, dbFilePath)
getParams _ = error "usage: DialInRecord port dbFilePath"

-- | Webserver accepting new entries and providing an up-to-date state.
scottyMain :: Int -> FilePath -> IO ()
scottyMain port dbFilePath = do

    -- Load persistent data.
    intialEntries <- loadEntries dbFilePath

    startTime     <- liftIO getNowUTC

    -- Always contains the up-to-date list of all entries.
    !allEntries <- intialEntries |> newTVar >>> atomically

    -- Up-to-date state,
    -- so must not be recalculated from allEntries every time.
    !currentState <- intialEntries |> calcState startTime
                                   |> newTVar >>> atomically

    -- Allow the backend to provide arbitrary messages (like error reports).
    messages <- atomically $ newTVar ""

    -- Dispatch new entries to saving thread.
    insertQueue <- atomically newTQueue

    -- Spawn persistency thread.
    void $ forkIO $ saveThreadFunc dbFilePath currentState insertQueue
                                   messages allEntries 0

    -- Start webserver.
    scotty port $ do

        let readTVarIOAtom = readTVar >>> atomically >>> liftIO
        let getState = currentState |> readTVarIOAtom
        let getMessages = messages |> readTVarIOAtom
        let getHistory s = extractHistory s <$> readTVarIOAtom allEntries

        get "/" $
            redirect "/index.html"

        get "/laststatemodtimeutc" $
            getState >>= (lastModTimeUTC >>> show >>> pack >>> text)

        get "/currenttimeutc" $
            liftIO getNowUTC >>= (show >>> pack >>> text)

        get "/state" $
            getState >>= (toJSON >>> json)

        get "/history" $ do
            getHistory "" >>= (pack >>> text)

        get "/history/:site" $ do
            s <- param "site"
            getHistory (unpack s) >>= (pack >>> text)

        get "/messages" $
            getMessages >>= (pack >>> text)

        post "/insert" $ do
            let paramToStr = param >>> fmap unpack
            postNow    <- liftIO getNowUTC
            postAction <- paramToStr "action"
            postUser   <- paramToStr "user"
            postSite   <- paramToStr "site"
            postReason <- param "reason"
            let entry = Entry postNow postAction postUser postSite postReason
            writeTQueue insertQueue entry |> atomically |> liftIO
            text "OK"

        post "/devnull" $ do
            text "OK"

        -- front end
        get "/:fileName" $ do
            fileName <- param "fileName"
            file $ "../frontend/build/" ++ fileName

        liftIO $ logMsg "Server started."

showHistoryEntry :: Bool -> Entry -> String
showHistoryEntry showSite e =
    formatLogTime (timeutc e |> fromIntegral |> posixSecondsToUTCTime) ++
    ": " ++
    user e ++ ", " ++
    (if showSite then (site e ++ ", ") else "") ++
    action e ++ ", " ++
    reason e

extractHistory :: String -> Entries -> String
extractHistory s entries =
    let allSites = null s
    in  entries
        |> filter (if allSites then (const True) else (\e -> site e == s))
        |> sortBy (compare `on` timeutc)
        |> reverse
        |> map (showHistoryEntry allSites)
        |> intercalate "\n"
        |> (\str -> "History for " ++ s ++ "\n\n" ++ str)

putStrLnAndFlush :: Handle -> String -> IO ()
putStrLnAndFlush hdl str = do
    hPutStrLn hdl str
    hFlush hdl

formatLogTime :: FormatTime t => t -> String
formatLogTime t = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S (UTC)" t

getLogLineStart :: IO String
getLogLineStart = do
    utcNow <- posixSecondsToUTCTime <$> getPOSIXTime
    return $ (formatLogTime utcNow) ++ ": "

logMsg :: String -> IO ()
logMsg str = do
    start <- getLogLineStart
    putStrLnAndFlush stdout (start ++ str ++ "\n")

logErr :: TVar String -> String -> IO ()
logErr messages str = do
    start <- getLogLineStart
    let msg = start ++ str
    putStrLnAndFlush stderr msg
    modifyTVar' messages (++ (msg ++ "\n")) |> atomically |> liftIO

-- | Wait for queued new entries and save them.
--   Creates a backup once a week
saveThreadFunc :: FilePath -> TVar State -> TQueue Entry -> TVar String
                  -> TVar Entries -> Int -> IO ()
saveThreadFunc dbFilePath state queue messages allEntries =
    iterateM_ $ \lastBackupTime -> do
        entry <- readTQueue queue |> atomically
        now <- liftIO getNowUTC
        let atomIO = atomically >>> liftIO
        modifyTVar' state (updateState now entry) |> atomIO
        modifyTVar' allEntries (entry :) |> atomIO
        allEntriesRead <- readTVar allEntries |> atomIO
        catch (do
                   saveEntries dbFilePath allEntriesRead
                   let makeNewBackup = now >= lastBackupTime + 86400
                   when makeNewBackup
                       (backupEntries dbFilePath (timeutc entry)
                                      allEntriesRead)
                   return (if makeNewBackup then now else lastBackupTime))
              (\e -> do let err = show (e :: IOException)
                        logErr messages err
                        return 0)

-- | Calculate new State dependent on a new entry.
updateState :: Int -> Entry -> State -> State
updateState newLasModTimeUTC newEntry state =
    newEntry : (relevantEntries state) |> calcState newLasModTimeUTC

-- | For consistency the timestamp of entries is generated by the server,
--   not by the client.
getNowUTC :: IO Int
getNowUTC = round `fmap` getPOSIXTime

-- | Read all entries from file system.
--   Partial, throws and error if something fails.
loadEntries :: FilePath -> IO Entries
loadEntries dbFilePath = do
    fileExists <- doesFileExist dbFilePath
    when (not fileExists) $ do
        logMsg ("Creating empty database " ++ dbFilePath)
        writeFile dbFilePath "[]"
    maybeEntries <- Aeson.decodeStrict <$> B.readFile dbFilePath
    return $ fromMaybe
                ( do
                    void $ error $ "Unable to read and parse " ++ dbFilePath
                    [] )
                maybeEntries

-- | Save all entries to file system.
saveEntries :: FilePath -> Entries -> IO ()
saveEntries dbFilePath =
    toJSON >>> PrettyAeson.encodePretty >>> L.writeFile dbFilePath

-- | Create a time stamped backup.
backupEntries :: FilePath -> Int -> Entries -> IO ()
backupEntries dbFilePath changeTimeUTC entries = do
    let dir = dbFilePath ++ ".backup"
    dirExists <- doesDirectoryExist dir
    when (not dirExists) $ do
        logMsg ("Creating backup directory " ++ dir)
        createDirectory dir
    saveEntries (dbFilePath ++ ".backup" </> show changeTimeUTC) entries

-- | Extract the relevant entries that represent the current state.
calcState :: Int -> Entries -> State
calcState newLasModTimeUTC entries = State relevant newLasModTimeUTC
    where
        relevant = dict |> Map.toList
                        |> map (snd >>> maximumBy (compare `on` timeutc))
        dict = Map.fromListWith (++) (map (key &&& (: [])) entries)
        key e = (user e, site e)

Entry.hs:

{-
    Entry.hs
-}

{-# LANGUAGE OverloadedStrings #-}

module Entry where

import Control.Applicative
import Data.Aeson.Types

data Entry = Entry {
    timeutc :: Int
  , action  :: String
  , user    :: String
  , site    :: String
  , reason  :: String
  } deriving Show

instance ToJSON Entry where
    toJSON entry  = object [
        "timeutc" .= timeutc entry
      , "action"  .= action entry
      , "user"    .= user entry
      , "site"    .= site entry
      , "reason"  .= reason entry
      ]

instance FromJSON Entry where
    parseJSON (Object v) = Entry <$>
                      v .: "timeutc" <*>
                      v .: "action"  <*>
                      v .: "user"    <*>
                      v .: "site"    <*>
                      v .: "reason"
    parseJSON _ = error "unable to parse JSON Entry"

type Entries = [Entry]

data State = State {
    relevantEntries :: Entries
  , lastModTimeUTC  :: Int
  } deriving Show

instance ToJSON State where
    toJSON state = toJSON $ relevantEntries state

cabal file:

name:                DialInRecord
version:             0.1.0
synopsis:            Allow manual logging of dial-ups
author:              Tobias Hermann
build-type:          Simple
cabal-version:       >=1.8

executable DialInRecord
  main-is:             Main.hs
  -- other-modules:
  build-depends:       base ==4.*
                     , aeson
                     , stm
                     , mtl
                     , text
                     , time
                     , aeson-pretty
                     , bytestring
                     , containers
                     , scotty
                     , monad-loops
                     , filepath
                     , directory
                     , old-locale

The only specific problem that I have is the memory consumption. When I start the program (running under Windows), it takes only a few MB. After a week or so it is at about 100MB. Ideas regarding what the cause could be, would be awesome.

If you want to reproduce the memory consumption problem, you can download the code here. If you are using Windows, just run 01_compile.bat, 02_run.bat and then 03_simulate_traffic.bat repeatedly. You can see the memory usage grow in the task manager. The bounty is for finding and fixing the memory consumption problem. :)

I think I reduced the memory problem to a minimal example. So I opened an issue in the scotty repo.

Answer 1

I just updated everything to the newest versions via cabal, and now the memory consumption problem does not occur any more.