Repackage for cabal-install support
This commit is contained in:
parent
c0f0451bd0
commit
9cdbce9508
@ -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
|
@ -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
|
@ -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
|
Loading…
Reference in New Issue
Block a user