@@ -1,4 +1,3 @@
1−{-# LANGUAGE EmptyCase #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE LambdaCase #-}
@@ -6,6 +5,14 @@
65{-# LANGUAGE TypeFamilies #-}
76module Backend where
87
8+import Control.Monad.IO.Class
9+import Data.Word
10+import Data.ByteString.Lazy
11+import Database.PostgreSQL.Simple
12+import Database.Id.Class
13+import Data.Text (Text)
14+import qualified Data.Aeson as A
15+import Data.Pool
916import Prelude hiding (id)
1017import Common.Route
1118import Obelisk.Backend
@@ -13,22 +20,46 @@ import Obelisk.Route
1320import Snap.Core
1421import Gargoyle.PostgreSQL.Connect
1522
23+maxUrlSize :: Word64
24+maxUrlSize = 2000
25+
26+migration :: Query
27+migration = "CREATE TABLE IF NOT EXISTS urls\
28+ \ (id SERIAL PRIMARY KEY, url VARCHAR(?) NOT NULL);"
29+
1630backend :: Backend BackendRoute FrontendRoute
1731backend = Backend
1832 { _backend_run = \serve -> do
19− withDb "db" $ \pool ->
33+ withDb "db" $ \pool -> do
34+ _ <- withResource pool $ \dbcon -> execute dbcon migration [maxUrlSize]
2035 serve $ \case
21− BackendRoute_Missing :/ () -> do
22− modifyResponse $ setResponseStatus 400 "Malformed Request"
23− writeBS "400 Malformed Request"
24− r <- getResponse
25− finishWith r
36+
37+ BackendRoute_Get_Url :/ id -> do
38+ result <- liftIO $ withResource pool $ \dbcon ->
39+ query dbcon "SELECT (url) FROM urls WHERE id = ?;" [unId id]
40+ case result of
41+ [[url]] -> redirect url
42+ _ -> do
43+ modifyResponse $ setResponseStatus 404 "Not Found"
44+ writeText "That shortlink wasn't found ¯\\_(ツ)_/¯"
45+ r <- getResponse
46+ finishWith r
47+
2648 BackendRoute_Shorten :/ () -> do
49+ Just url <- A.decode <$> readRequestBody maxUrlSize
50+ [[id]] <- liftIO $ withResource pool $ \dbcon -> do
51+ _ <- execute dbcon "INSERT INTO urls (url) values (?);" [url :: Text]
52+ query_ dbcon "SELECT last_value FROM urls_id_seq;"
2753 modifyResponse $ setResponseStatus 200 "OK"
28− writeBS $ "\"OK\""
54+ writeBS $ toStrict $ A.encode $ ("/s/" <>) $ show (id :: Int)
55+ r <- getResponse
56+ finishWith r
57+
58+ _ -> do
59+ modifyResponse $ setResponseStatus 400 "Malformed Request"
60+ writeBS "400 Malformed Request"
2961 r <- getResponse
3062 finishWith r
31− _ -> error "no"
3263 return ()
3364 , _backend_routeEncoder = fullRouteEncoder
3465 }