diff --git a/Main.hs b/Main.hs
deleted file mode 100644
--- a/Main.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-import Application
-import Breve.Common
-
-import Control.Applicative
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
-
-main :: IO ()
-main = do
- (url, settings) <- serverSettings
- putStrLn ("Serving on " ++ url)
- app (runSettings settings . logStdout)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -2,13 +2,15 @@
### a url shortener
Breve is a web application that provides a simple interface to
-shortening long urls creating smaller and easy to remember links.
+shortening long urls creating links smaller and easier to remember.
-It creates links like "/emeaoinqua" that easier to remember than
+It creates links in the form of "/emeaoinqua": easier to remember than
alphanumeric strings like "/1Cqw8lHw" used by several services.
+It was inspired by [hastebin](http://hastebin.com).
+
## Running the app
-
+
git clone https://github.com/rnhmjoj/breve
cd breve
cabal install --only-dependencies
@@ -17,7 +19,7 @@
This will start the app on `http://127.0.0.1:3000`
You can set the bind hostname/port via the `PORT` and `ADDRESS`
-environment variables
+environment variables.
## License
diff --git a/breve.cabal b/breve.cabal
--- a/breve.cabal
+++ b/breve.cabal
@@ -1,5 +1,5 @@
name: breve
-version: 0.0.1.0
+version: 0.0.2.0
synopsis: a url shortener
description:
@@ -15,6 +15,7 @@
category: Web
build-type: Simple
extra-source-files: README.md, LICENSE
+data-files: layouts/*.css, layouts/*.html, views/*.html
cabal-version: >=1.10
source-repository head
@@ -23,8 +24,12 @@
executable breve
main-is: Main.hs
+ hs-source-dirs: src
default-language: Haskell2010
- build-depends: base ==4.*, simple >= 0.8.0,
+ 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.*,
diff --git a/layouts/main.css b/layouts/main.css
new file mode 100644
--- /dev/null
+++ b/layouts/main.css
@@ -0,0 +1,88 @@
+@import url(http://fonts.googleapis.com/css?family=Inconsolata:400,700);
+@import url(http://reset5.googlecode.com/hg/reset.min.css);
+
+html, body { overflow: hidden }
+body, input { font-size: 1.1em }
+
+body {
+ background-color: rgb(24,27,32);
+ color: rgb(155,144,129);
+ font-family: Inconsolata;
+}
+
+#container {
+ text-align:center;
+ position: absolute;
+ height: 100%;
+ width: 100%;
+}
+
+#container:before {
+ content: '';
+ display: inline-block;
+ height: 100%;
+ vertical-align: middle;
+}
+
+#center {
+ display: inline-block;
+ text-align:left;
+ margin-top: -2em;
+}
+
+footer {
+ position: absolute;
+ width: 100%;
+ bottom: 0;
+ left: 0;
+ padding: 1em;
+ font-size: .9em;
+ color: rgb(89,84,80)
+}
+
+footer span {
+ float: right;
+ margin-right: 2em;
+}
+
+h1 {
+ margin: 1em 0 0 1em;
+ font-size: 1.8em;
+ font-weight: 700;
+ color: rgb(81,94,102);
+}
+
+h1 a { color: rgb(81,94,102) !important}
+
+h2 {
+ font-size: 1.2em;
+ margin: .5em 0 0 1.5em;
+}
+
+input[type="text"] {
+ border: none;
+ border-bottom: .15em dashed rgb(43,44,46);
+ outline: none;
+ background: transparent;
+ color: rgb(119,96,73);
+ padding: 0 2px;
+}
+
+input[type="submit"] {
+ border: .12em solid rgb(43,44,46);
+ padding: .2em .4em !important;
+ background: transparent;
+ color: rgb(119,87,80);
+ cursor: pointer;
+}
+
+a:link, a:visited {
+ color: rgb(119,96,73);
+ text-decoration: none;
+}
+
+a:hover {
+ text-decoration: underline;
+ transition: color .5s ease;
+ color: rgb(119,87,80);
+}
diff --git a/layouts/main.html b/layouts/main.html
new file mode 100644
--- /dev/null
+++ b/layouts/main.html
@@ -0,0 +1,22 @@
+
+
+
+ breve: url shortener
+
+
+
+
+
+
+
+
+ a url shortener
+
+
+
+
diff --git a/src/Application.hs b/src/Application.hs
new file mode 100644
--- /dev/null
+++ b/src/Application.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Application where
+
+import Breve.Common
+import Breve.UrlTable
+import Paths_breve (getDataFileName)
+
+import Web.Frank
+import Web.Simple
+import Web.Simple.Static (serveStatic)
+import Web.Simple.Templates (render)
+
+import Control.Applicative
+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
+ settings <- newAppSettings
+ (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 indexPath ())
+ get "/main.css" (serveStatic cssPath)
+
+ get "/:word" $ do
+ word <- queryParam' "word"
+ url <- liftIO (extract table word)
+ case url of
+ Just url -> do
+ logStr (printf "Resolved %s -> %s" word url)
+ respond $ redirectTo (BS.pack url)
+ Nothing -> respond notFound
+
+ post "/short" $ do
+ (form, _) <- parseForm
+ 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
diff --git a/src/Breve/Common.hs b/src/Breve/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Breve/Common.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Breve.Common where
+
+import Paths_breve (getDataFileName)
+
+import Control.Applicative
+import Control.Monad.IO.Class (liftIO)
+import Text.Printf (printf)
+import System.Environment (lookupEnv)
+
+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)
+
+newAppSettings :: IO AppSettings
+newAppSettings = return AppSettings
+
+instance HasTemplates IO AppSettings where
+ defaultLayout = do
+ main <- liftIO (getDataFileName "layouts/main.html")
+ Just <$> getTemplate main
diff --git a/src/Breve/Generator.hs b/src/Breve/Generator.hs
new file mode 100644
--- /dev/null
+++ b/src/Breve/Generator.hs
@@ -0,0 +1,37 @@
+module Breve.Generator
+( wordID
+, hashID
+, Word
+, Url
+) where
+
+import Control.Applicative
+import Control.Monad.State
+import System.Random
+import Crypto.Hash.SHA256 (hash)
+import Data.Binary (decode)
+import Data.ByteString.Char8 (pack)
+import Data.ByteString.Lazy (fromStrict)
+
+type Word = String
+type Url = String
+
+-- Choose a random element of a list
+choice :: [a] -> State StdGen a
+choice xs = (xs !!) <$> randomSt (0, length xs - 1)
+ where randomSt = state . randomR
+
+-- Generate a random phonetic string
+word :: State StdGen Word
+word = replicateM 10 letter where
+ vowels = "aeiou"
+ consonants = "bcdfghjklmnpqrstvwxyz"
+ letter = choice [vowels, consonants] >>= choice
+
+-- SHA256 hash to seed a generator
+hashID :: Url -> Int
+hashID = decode . fromStrict . hash . pack
+
+-- Assing a unique word to the url
+wordID :: Url -> Word
+wordID = evalState word . mkStdGen . hashID
diff --git a/src/Breve/UrlTable.hs b/src/Breve/UrlTable.hs
new file mode 100644
--- /dev/null
+++ b/src/Breve/UrlTable.hs
@@ -0,0 +1,24 @@
+module Breve.UrlTable
+( UrlTable
+, records
+, insert
+, extract
+) where
+
+import Breve.Generator
+import qualified Data.HashTable.IO as H
+
+type UrlTable = H.CuckooHashTable Word Url
+
+--Empty url hash table
+records :: IO UrlTable
+records = H.new
+
+-- Insert the url in the 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
+extract :: UrlTable -> Word -> IO (Maybe Url)
+extract = H.lookup
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Application
+import Breve.Common
+
+import Control.Applicative
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+
+main :: IO ()
+main = do
+ (url, settings) <- serverSettings
+ putStrLn ("Serving on " ++ url)
+ app (runSettings settings . logStdout)
diff --git a/views/done.html b/views/done.html
new file mode 100644
--- /dev/null
+++ b/views/done.html
@@ -0,0 +1,1 @@
+here's your new link: $link$
diff --git a/views/index.html b/views/index.html
new file mode 100644
--- /dev/null
+++ b/views/index.html
@@ -0,0 +1,4 @@
+