save url table on exit
This commit is contained in:
parent
7fdfb25ce0
commit
7e1e95fa2a
@ -5,6 +5,7 @@ to store the URLs in memory and on disk.
|
||||
module Breve.UrlTable
|
||||
( UrlTable
|
||||
, load
|
||||
, save
|
||||
, insert
|
||||
, extract
|
||||
) where
|
||||
@ -19,20 +20,26 @@ import qualified Data.HashTable.IO as H
|
||||
-- | The hash table that stores URLs
|
||||
type UrlTable = H.CuckooHashTable Name Url
|
||||
|
||||
-- | Periodically writes a 'UrlTable' to a file
|
||||
--
|
||||
-- The table is stored in a text file
|
||||
-- as Haskell code for semplicity.
|
||||
-- | Periodically save a 'UrlTable' to a file
|
||||
sync :: UrlTable -> FilePath -> IO ()
|
||||
sync table file = forever $ do
|
||||
threadDelay (round 3.0e8)
|
||||
save table file
|
||||
|
||||
-- | Writes a 'UrlTable' to a file
|
||||
--
|
||||
-- The table is stored in a text file
|
||||
-- as Haskell code for semplicity.
|
||||
save :: UrlTable -> FilePath -> IO ()
|
||||
save table file = do
|
||||
content <- show <$> H.toList table
|
||||
writeFile file content
|
||||
putStrLn "\n[breve] url table synced."
|
||||
|
||||
-- | Loads a URL table from a file
|
||||
--
|
||||
-- The format should be the same one used
|
||||
-- by the 'sync' function.
|
||||
-- Once the file is loaded it will be synced
|
||||
-- periodically (every 5min) on the disk.
|
||||
load :: FilePath -> IO UrlTable
|
||||
load file = do
|
||||
content <- readFile file
|
||||
|
10
src/Main.hs
10
src/Main.hs
@ -20,6 +20,7 @@ import Data.Maybe (listToMaybe)
|
||||
|
||||
-- IO
|
||||
import Control.Monad (when, void)
|
||||
import Control.Exception as E
|
||||
import Control.Concurrent (forkIO)
|
||||
import System.Environment (getArgs)
|
||||
import Data.Text.IO as T
|
||||
@ -61,9 +62,14 @@ main = do
|
||||
when (bindPort == 443) $ void $
|
||||
forkIO (run 80 $ forceSSL emptyApp)
|
||||
|
||||
-- Save the table just before exiting
|
||||
let exit E.UserInterrupt = save table urlTable
|
||||
exit e = throwIO e
|
||||
|
||||
-- Middlewares are functions (Application -> Application).
|
||||
-- We use one here to add requests
|
||||
let middlewares = logStdout
|
||||
|
||||
T.putStrLn ("Serving on " <> bindUrl)
|
||||
runApp config (middlewares $ breve static bindUrl table)
|
||||
handle exit $ do
|
||||
T.putStrLn ("Serving on " <> bindUrl)
|
||||
runApp config (middlewares $ breve static bindUrl table)
|
||||
|
Loading…
Reference in New Issue
Block a user