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.

• Carl: My first guess as to the source of your memory use is thunks building up inside the TVars. To actually verify it, I'd love to be able to grab a repo off github or something. Got a link for the source?
• Tobias Hermann: @Carl Sorry for the late reply. It would be awesome if you could have a look at it. At the bottom of my post you can find an edit with a download link to the code and short instruction on how to reproduce the problem.

Answer 1

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