Repackage for cabal-install support

master
rnhmjoj 2015-04-09 17:11:27 +02:00
parent c0f0451bd0
commit 9cdbce9508
5 changed files with 31 additions and 28 deletions

View File

@ -3,20 +3,21 @@ module Application where
import Breve.Common
import Breve.UrlTable
import Paths_breve (getDataFileName)
import Web.Simple
import Web.Simple.Static
import Web.Simple.Templates
import Web.Frank
import Web.Simple
import Web.Simple.Static (serveStatic)
import Web.Simple.Templates (render)
import Control.Applicative
import Control.Monad.IO.Class
import Text.Printf
import Data.Maybe
import Control.Monad.IO.Class (liftIO)
import Text.Printf (printf)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
logStr = liftIO . putStrLn
app :: (Application -> IO ()) -> IO ()
app runner = do
@ -24,25 +25,28 @@ app runner = do
(baseUrl,_) <- serverSettings
table <- records
cssPath <- getDataFileName "layouts/main.css"
indexPath <- getDataFileName "views/index.html"
donePath <- getDataFileName "views/done.html"
runner $ controllerApp settings $ do
get "/" (render "index.html" ())
get "/main.css" (serveStatic "layouts/main.css")
get "/" (render indexPath ())
get "/main.css" (serveStatic cssPath)
get "/:word" $ do
word <- queryParam' "word"
url <- liftIO (extract table word)
case url of
Just url -> do
liftIO $ putStrLn (printf "Resolved %s -> %s" word url)
logStr (printf "Resolved %s -> %s" word url)
respond $ redirectTo (BS.pack url)
Nothing -> respond notFound
post "/short" $ do
(form, _) <- parseForm
case lookup "url" form of
Just url' -> do
let url = BS.unpack url'
word <- liftIO (insert table url)
liftIO $ putStrLn (printf "Registered %s -> %s " url word)
render "done.html" $ object ["link" .= (baseUrl ++ word)]
case BS.unpack <$> lookup "url" form of
Just url -> do
word <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url word)
render donePath $ object ["link" .= (baseUrl ++ word)]
Nothing -> respond badRequest

View File

@ -1,22 +1,23 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Breve.Common where
import Control.Applicative
import Text.Printf
import Data.String
import System.Environment
import Network.Wai.Handler.Warp
import Paths_breve (getDataFileName)
import Control.Applicative
import Control.Monad.IO.Class (liftIO)
import Text.Printf (printf)
import System.Environment (lookupEnv)
import Web.Simple
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 "127.0.0.1" id <$> lookupEnv "ADDRESS"
let opts = setPort port $ setHost (fromString host) defaultSettings
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
@ -26,4 +27,6 @@ newAppSettings :: IO AppSettings
newAppSettings = return AppSettings
instance HasTemplates IO AppSettings where
defaultLayout = Just <$> getTemplate "layouts/main.html"
defaultLayout = do
main <- liftIO (getDataFileName "layouts/main.html")
Just <$> getTemplate main

View File

@ -6,10 +6,6 @@ module Breve.UrlTable
) where
import Breve.Generator
import Control.Applicative
import Control.Monad
import Data.Maybe
import qualified Data.HashTable.IO as H
type UrlTable = H.CuckooHashTable Word Url