diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ It was inspired by [hastebin](http://hastebin.com). -## Installing the app +## Installing Install the app with cabal-install. Run @@ -21,7 +21,21 @@ The app will start serving on `http://localhost:3000`, listening on every active interface. -You can change the port and set a hostname via the `PORT` and `HOSTNAME` environment variables. +## Configure + +You can change the options by editing the config file. +When you start the app an empty one will be created in: +`$XDG_CONFIG_HOME/breve` or `~/.config/breve` if unset. + +The default values are: + +```ini +hostname localhost +port 3000 +urltable $XDG_CONFIG_HOME/breve +``` + +`urltable` is the location of breve url hashtable ## License diff --git a/breve.cabal b/breve.cabal --- a/breve.cabal +++ b/breve.cabal @@ -1,5 +1,5 @@ name: breve -version: 0.0.2.2 +version: 0.0.3.0 synopsis: a url shortener description: @@ -29,10 +29,9 @@ other-modules: Application, Breve.Common, Breve.Generator, Breve.UrlTable other-extensions: OverloadedStrings - build-depends: base ==4.*, simple >= 0.8.0, - wai ==2.*, wai-extra ==2.*, warp ==2.1.*, - aeson ==0.8.*, bytestring ==0.10.*, - transformers ==0.3.*, mtl ==2.1.*, - hashtables ==1.2.*, cryptohash ==0.11.*, - binary ==0.7.*, random ==1.1.* + build-depends: base ==4.*, simple >= 0.8.0, wai ==2.*, wai-extra ==2.*, + warp ==2.1.*, aeson ==0.8.*, bytestring ==0.10.*, + transformers ==0.3.*, mtl ==2.1.*, hashtables ==1.2.*, + cryptohash ==0.11.*, binary ==0.7.*, random ==1.1.*, + xdg-basedir ==0.2.*, tconfig ==0.5.*, directory ==1.2.* ghc-options: -threaded -O2 diff --git a/src/Application.hs b/src/Application.hs --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Application where import Breve.Common @@ -21,17 +21,17 @@ app :: (Application -> IO ()) -> IO () app runner = do - settings <- newAppSettings - (baseUrl,_) <- serverSettings - table <- records + settings <- newAppSettings + ServerSettings {..} <- newServerSettings + table <- load urlTable - cssPath <- getDataFileName "layouts/main.css" - indexPath <- getDataFileName "views/index.html" - donePath <- getDataFileName "views/done.html" + css <- getDataFileName "layouts/main.css" + index <- getDataFileName "views/index.html" + done <- getDataFileName "views/done.html" runner $ controllerApp settings $ do - get "/" (render indexPath ()) - get "/main.css" (serveStatic cssPath) + get "/" (render index ()) + get "/main.css" (serveStatic css) get "/:word" $ do word <- queryParam' "word" @@ -48,5 +48,5 @@ Just url -> do word <- liftIO (insert table url) logStr (printf "Registered %s -> %s " url word) - render donePath $ object ["link" .= (baseUrl ++ word)] + render done $ object ["link" .= (bindUrl ++ word)] Nothing -> respond badRequest diff --git a/src/Breve/Common.hs b/src/Breve/Common.hs --- a/src/Breve/Common.hs +++ b/src/Breve/Common.hs @@ -1,32 +1,63 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Breve.Common where -import Paths_breve (getDataFileName) +import Paths_breve (getDataFileName) import Control.Applicative -import Control.Monad.IO.Class (liftIO) -import Text.Printf (printf) -import System.Environment (lookupEnv) +import Control.Monad.IO.Class (liftIO) +import Text.Printf (printf) +import System.Environment (lookupEnv) +import System.Environment.XDG.BaseDir +import System.Directory (doesFileExist) +import Data.TConfig import Web.Simple.Templates import Network.Wai.Handler.Warp -data AppSettings = AppSettings { } - -serverSettings :: IO (String, Settings) -serverSettings = do - port <- maybe 3000 read <$> lookupEnv "PORT" - host <- maybe "localhost" id <$> lookupEnv "HOSTNAME" - let opts = setPort port defaultSettings - url = if port == 80 - then printf "http://%s/" host - else printf "http://%s:%d/" host port - return (url, opts) +data ServerSettings = ServerSettings + { bindPort :: Int + , bindHostname :: String + , bindUrl :: String + , urlTable :: FilePath + , warpSettings :: Settings + } -newAppSettings :: IO AppSettings -newAppSettings = return AppSettings +data AppSettings = AppSettings {} instance HasTemplates IO AppSettings where defaultLayout = do main <- liftIO (getDataFileName "layouts/main.html") Just <$> getTemplate main + + +newAppSettings :: IO AppSettings +newAppSettings = return AppSettings + +createEmptyIfMissing :: FilePath -> IO FilePath +createEmptyIfMissing file = do + exists <- doesFileExist file + if not exists + then writeFile file "" >> return file + else return file + +newServerSettings :: IO ServerSettings +newServerSettings = do + urlsPath <- getUserDataFile "breve" "" + configPath <- getUserConfigFile "breve" "" + + config <- readConfig =<< createEmptyIfMissing configPath + let host = maybe "localhost" id (getValue "hostname" config) + port = maybe 3000 read (getValue "port" config) + urls = maybe urlsPath id (getValue "urltable" config) + + createEmptyIfMissing urls + + return ServerSettings + { bindPort = port + , bindHostname = host + , bindUrl = if port == 80 + then printf "http://%s/" host + else printf "http://%s:%d/" host port + , urlTable = urls + , warpSettings = setPort port defaultSettings + } diff --git a/src/Breve/UrlTable.hs b/src/Breve/UrlTable.hs --- a/src/Breve/UrlTable.hs +++ b/src/Breve/UrlTable.hs @@ -1,24 +1,41 @@ module Breve.UrlTable ( UrlTable -, records +, load , insert , extract ) where import Breve.Generator + +import Control.Monad (forever) +import Control.Concurrent (forkIO, threadDelay) +import Text.Read (readMaybe) import qualified Data.HashTable.IO as H type UrlTable = H.CuckooHashTable Word Url ---Empty url hash table -records :: IO UrlTable -records = H.new +-- Periodically write a url table to a file +sync :: UrlTable -> FilePath -> IO () +sync table file = forever $ do + threadDelay (round 3.0e8) + content <- fmap show (H.toList table) + writeFile file content --- Insert the url in the table and return the word +-- Load a url table from a file +load :: FilePath -> IO UrlTable +load file = do + content <- readFile file + table <- case readMaybe content of + Just list -> H.fromList list + Nothing -> H.new + forkIO (sync table file) + return table + +-- Insert the url in a table and return the word insert :: UrlTable -> Url -> IO Word insert table url = H.insert table new url >> return new where new = wordID url --- Lookup the table for the associated url +-- Lookup a table for the associated url extract :: UrlTable -> Word -> IO (Maybe Url) extract = H.lookup diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} import Application import Breve.Common @@ -9,6 +9,6 @@ main :: IO () main = do - (url, settings) <- serverSettings - putStrLn ("Serving on " ++ url) - app (runSettings settings . logStdout) + ServerSettings {..} <- newServerSettings + putStrLn ("Serving on " ++ bindUrl) + app (runSettings warpSettings . logStdout)