bb65d53 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

backend persistence and redirects working

bb65d53Owen Shepherd7 years ago

examples/url-shortener/backend/src/Backend.hs+40−9

compare with master

unifiedsplit

@@ -1,4 +1,3 @@

1−{-# LANGUAGE EmptyCase #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE LambdaCase #-}

@@ -6,6 +5,14 @@

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7module Backend where

6module Backend where

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

9import Prelude hiding (id)

16import Prelude hiding (id)

10import Common.Route

17import Common.Route

11import Obelisk.Backend

18import Obelisk.Backend

@@ -13,22 +20,46 @@ import Obelisk.Route

13import Snap.Core

20import Snap.Core

14import Gargoyle.PostgreSQL.Connect

21import Gargoyle.PostgreSQL.Connect

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+

16backend :: Backend BackendRoute FrontendRoute

30backend :: Backend BackendRoute FrontendRoute

17backend = Backend

31backend = Backend

18 { _backend_run = \serve -> do

32 { _backend_run = \serve -> do

19− withDb "db" $ \pool ->

33+ withDb "db" $ \pool -> do

34+ _ <- withResource pool $ \dbcon -> execute dbcon migration [maxUrlSize]

20 serve $ \case

35 serve $ \case

21− BackendRoute_Missing :/ () -> do

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

22− modifyResponse $ setResponseStatus 400 "Malformed Request"

43+ modifyResponse $ setResponseStatus 404 "Not Found"

23− writeBS "400 Malformed Request"

44+ writeText "That shortlink wasn't found ¯\\_(ツ)_/¯"

24− r <- getResponse

45+ r <- getResponse

25− finishWith r

46+ finishWith r

47+

26 BackendRoute_Shorten :/ () -> do

48 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;"

27 modifyResponse $ setResponseStatus 200 "OK"

53 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"

29 r <- getResponse

61 r <- getResponse

30 finishWith r

62 finishWith r

31− _ -> error "no"

32 return ()

63 return ()

33 , _backend_routeEncoder = fullRouteEncoder

64 , _backend_routeEncoder = fullRouteEncoder

34 }

65 }

examples/url-shortener/common/src/Common/Api.hs+1−2

@@ -3,7 +3,6 @@

3{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE TemplateHaskell #-}

7{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9module Common.Api where

8module Common.Api where

@@ -12,4 +11,4 @@ import Data.Aeson

12import Data.Text (Text)

11import Data.Text (Text)

13import GHC.Generics (Generic)

12import GHC.Generics (Generic)

15−data ShortenRequest = ShortenRequest Text deriving (Generic, ToJSON, FromJSON)

14+newtype ShortenRequest = ShortenRequest Text deriving (Generic, ToJSON, FromJSON)

examples/url-shortener/common/src/Common/Route.hs+2−3

@@ -5,7 +5,6 @@

5{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE TemplateHaskell #-}

7{-# LANGUAGE KindSignatures #-}

8−{-# LANGUAGE EmptyCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

11{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

@@ -31,7 +30,7 @@ import Common.Schema

32data BackendRoute :: * -> * where

31data BackendRoute :: * -> * where

33 BackendRoute_Missing :: BackendRoute ()

32 BackendRoute_Missing :: BackendRoute ()

34− BackendRoute_Url_Id :: BackendRoute (Id Url)

33+ BackendRoute_Get_Url :: BackendRoute (Id Url)

35 -- TODO validate this or use a URL type

34 -- TODO validate this or use a URL type

36 BackendRoute_Shorten :: BackendRoute ()

35 BackendRoute_Shorten :: BackendRoute ()

@@ -50,7 +49,7 @@ fullRouteEncoder = mkFullRouteEncoder

50 (FullRoute_Backend BackendRoute_Missing :/ ())

49 (FullRoute_Backend BackendRoute_Missing :/ ())

51 (\case

50 (\case

52 BackendRoute_Shorten -> PathSegment "create" $ unitEncoder mempty

51 BackendRoute_Shorten -> PathSegment "create" $ unitEncoder mempty

53− BackendRoute_Url_Id -> PathSegment "s" idPathSegmentEncoder

52+ BackendRoute_Get_Url -> PathSegment "s" idPathSegmentEncoder

54 BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)

53 BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)

55 (\case

54 (\case

56 FrontendRoute_Main -> PathEnd $ unitEncoder mempty)

55 FrontendRoute_Main -> PathEnd $ unitEncoder mempty)

examples/url-shortener/common/src/Common/Schema.hs+1−1

@@ -5,7 +5,7 @@ import Data.Text (Text)

5import Database.Id.Class

6import GHC.Generics

8−data Url = Url { unUrl :: Text }

8+newtype Url = Url { unUrl :: Text }

9 deriving Generic

11instance HasId Url

examples/url-shortener/frontend/src/Frontend.hs+11−14

@@ -3,8 +3,6 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE RecursiveDo #-}

7−{-# LANGUAGE TemplateHaskell #-}

8{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE TypeApplications #-}

9module Frontend where

7module Frontend where

@@ -20,14 +18,14 @@ import Common.Route

20import Obelisk.Generated.Static

18import Obelisk.Generated.Static

22type AppWidget js t m =

20type AppWidget js t m =

23− ( DomBuilder t m

21+ ( DomBuilder t m

24− , MonadFix m

22+ , MonadFix m

25− , MonadHold t m

23+ , MonadHold t m

26− , TriggerEvent t m

24+ , TriggerEvent t m

27− , PostBuild t m

25+ , PostBuild t m

28− , PerformEvent t m

26+ , PerformEvent t m

29− , Prerender js t m

27+ , Prerender js t m

30− )

28+ )

32type FrontendWidget js t m =

30type FrontendWidget js t m =

33 ( AppWidget js t m

31 ( AppWidget js t m

@@ -47,7 +45,7 @@ urlInput = do

47 let url = tagPromptlyDyn (_inputElement_value inputEl) click

45 let url = tagPromptlyDyn (_inputElement_value inputEl) click

48 request <- prerender

46 request <- prerender

49 (pure never)

47 (pure never)

50− ((decodeXhrResponse <$>) <$> (performRequestAsync $ shortenRequest <$> url))

48+ ((decodeXhrResponse <$>) <$> performRequestAsync (shortenRequest <$> url))

51 let requestEv = switchDyn request

49 let requestEv = switchDyn request

52 holdDyn NotStarted $

50 holdDyn NotStarted $

53 leftmost [Loading <$ click, Loaded <$> requestEv]

51 leftmost [Loading <$ click, Loaded <$> requestEv]

@@ -64,7 +62,7 @@ createdLink = \case

64 Loading -> text "loading"

62 Loading -> text "loading"

65 Loaded a -> case a of

63 Loaded a -> case a of

66 Nothing -> text "Error"

64 Nothing -> text "Error"

67− Just url -> text url

65+ Just url -> elAttr "a" ("href" =: url) $ text url

69app :: AppWidget js t m => m ()

67app :: AppWidget js t m => m ()

70app = do

68app = do

@@ -77,6 +75,5 @@ frontend = Frontend

77 { _frontend_head = do

75 { _frontend_head = do

78 el "title" $ text "Url Shortener"

76 el "title" $ text "Url Shortener"

79 elAttr "link" ("rel" =: "stylesheet" <> "href" =: static @"style.css") blank

77 elAttr "link" ("rel" =: "stylesheet" <> "href" =: static @"style.css") blank

80− , _frontend_body = do

78+ , _frontend_body = app

81− app

82 }

79 }