Permalink
Browse files

Merge branch 'document-entities-for-id-payload'

  • Loading branch information...
tippenein committed Aug 3, 2016
2 parents 1510b71 + 1afc654 commit c3cb78197f0b470f944789a3b0552a42fd369aca
Showing with 101 additions and 51 deletions.
  1. +6 −6 executable/Main.hs
  2. +8 −4 hasken.cabal
  3. +3 −2 lib/Local/Sync.hs
  4. +16 −5 lib/Remote/API.hs
  5. +17 −11 lib/Remote/Client.hs
  6. +23 −6 lib/Remote/Database.hs
  7. +1 −1 site/Document.tywi
  8. +1 −1 site/Makefile
  9. +6 −6 site/src/Gen/Document.elm
  10. +17 −7 site/src/Main.elm
  11. +3 −2 stack.yaml
@@ -104,12 +104,12 @@ showHelpText :: ParserPrefs -> ParserInfo a -> IO ()
showHelpText pprefs pinfo = handleParseResult . Failure $
parserFailure pprefs pinfo ShowHelpText mempty
defaultPrefs = ParserPrefs
{ prefMultiSuffix = ""
, prefDisambiguate = False
, prefShowHelpOnError = False
, prefBacktrack = True
, prefColumns = 80 }
-- defaultPrefs = ParserPrefs
-- { prefMultiSuffix = ""
-- , prefDisambiguate = False
-- , prefShowHelpOnError = False
-- , prefBacktrack = True
-- , prefColumns = 80 }
run' :: Options -> IO ()
run' opts =
@@ -18,7 +18,7 @@ source-repository head
library
hs-source-dirs: lib
ghc-options: -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
exposed-modules:
Local
, Remote
@@ -30,6 +30,9 @@ library
, Remote.Database
, Remote.Server
, Remote.Main
other-modules:
Remote.Config
, Paths_hasken
build-depends:
base
, acid-state
@@ -40,9 +43,10 @@ library
, mtl
, safecopy
, resourcet
, servant >= 0.4
, servant-client >= 0.4
, servant-server >= 0.4
, servant >= 0.7
, servant-client >= 0.7
, servant-server >= 0.7
, http-client
, split
, text
, monad-logger
@@ -4,6 +4,7 @@ import Data.Text (pack, unpack)
import Local.Document (Document (..))
import qualified Remote.Client as Client
import qualified Remote.Database as DB
import Database.Persist.Sqlite
import System.IO.Unsafe (unsafePerformIO)
import Config
@@ -18,8 +19,8 @@ createDoc d = Client.createDocument doc
, DB.documentTags = fmap pack (tags d)
}
fromDatabaseDoc :: DB.Document -> Document
fromDatabaseDoc d = Document {
fromDatabaseDoc :: Entity DB.Document -> Document
fromDatabaseDoc (Entity _ d) = Document {
title = unpack $ DB.documentTitle d,
content = unpack $ DB.documentContent d,
tags = fmap unpack (DB.documentTags d)
@@ -1,27 +1,38 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Remote.API where
import Data.Aeson
import Data.Proxy
import Data.Text (Text)
import Data.Text (Text)
import Database.Persist.Sqlite
import Remote.Database
import Servant.API
documentAPI :: Proxy DocumentAPI
documentAPI = Proxy
instance FromJSON Document where
instance FromJSON (Entity Document) where
parseJSON = entityIdFromJSON
-- parseJSON obj@(Object v) = Entity <$> v .: "id" <*> parseJSON obj
type DocumentAPI =
ListDocuments
:<|> CreateDocument
type ListDocuments =
"documents"
:> Capture "user_key" Text
:> Get '[JSON] [Document]
:> Get '[JSON] [Entity Document]
type CreateDocument =
"documents"
:> ReqBody '[JSON] Document
:> Post '[JSON] Document
:> Post '[JSON] (Entity Document)
@@ -1,8 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Remote.Client where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Either
import Servant hiding (host)
import Servant.Client hiding (host)
import System.IO.Unsafe (unsafePerformIO)
@@ -11,14 +12,6 @@ import Data.Text as T
import qualified Config
import Remote.API
type Action a = EitherT ServantError IO a
run :: Action a -> IO a
run action = do
result <- runEitherT action
case result of
Left message -> error (show message)
Right x -> return x
{-# NOINLINE ukey #-}
ukey = unsafePerformIO $ Config.userKey <$> Config.remoteConfig
@@ -27,10 +20,23 @@ makeBaseUrl :: IO BaseUrl
makeBaseUrl = do
h <- Config.domain <$> Config.remoteConfig
p <- Config.port <$> Config.remoteConfig
return $ BaseUrl Http h p
pure $ BaseUrl Http h p ""
type Action a = ExceptT ServantError IO a
run action = do
baseUrl <- makeBaseUrl
manager <- newManager defaultManagerSettings
result <- runExceptT $ action manager baseUrl
case result of
Left message -> error (show message)
Right x -> pure x
listDocuments' :<|> createDocument' =
client documentAPI (unsafePerformIO makeBaseUrl)
client documentAPI
listDocumentsWith client_id = run $ listDocuments' client_id
listDocuments = run $ listDocuments' (T.pack ukey)
createDocument doc = run $ createDocument' doc
@@ -21,6 +21,7 @@ module Remote.Database
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import Data.Aeson
import Data.Int (Int64)
import Data.Text (Text)
import Database.Persist
@@ -45,7 +46,7 @@ envDb = do
_ -> return "hasken.dev.db"
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Document json
Document
userKey Text
title Text
content Text
@@ -54,17 +55,33 @@ Document json
deriving Eq Show Generic
|]
selectDocuments :: Text -> IO [Document]
instance ToJSON Document where
toJSON (Document _ t c ts) = object
[ "title" .= t
, "content" .= c
, "tags" .= ts
]
instance ToJSON (Entity Document) where
toJSON (Entity pid (Document _ t c ts)) = object
[ "id" .= pid
, "title" .= t
, "content" .= c
, "tags" .= ts
]
selectDocuments :: Text -> IO [Entity Document]
selectDocuments userKey = do
docs <- runDB $ selectList [DocumentUserKey ==. userKey] []
return $ map entityVal docs
return docs
insertDocument :: Document -> IO Document
insertDocument :: Document -> IO (Entity Document)
insertDocument o = do
d <- runDB $ insertBy o
case d of
Left _ -> putStrLn "record already exists" >> return o
Right _ -> putStrLn "inserted record" >> return o
Left existed -> putStrLn "record already exists" >> pure existed
Right new -> putStrLn "inserted record" >> pure (Entity new o)
-- insertDb :: a -> IO a
-- insertDb o = do
@@ -1,8 +1,8 @@
module Document;
type Document{
id : Int;
title : String;
userKey : String;
content : String;
tags : List<String>;
}
@@ -1,5 +1,5 @@
gen:
twirec -e Document -i . --elm-out src/Gen
twirec -e Document -i . --elm-out src/Gen --elm-version 0.17
build:
elm package install
@@ -9,8 +9,8 @@ import Json.Decode exposing ((:=))
import Json.Encode as JE
type alias Document =
{ title : String
, userKey : String
{ id : Int
, title : String
, content : String
, tags : (List String)
}
@@ -19,16 +19,16 @@ jencDocument : Document -> JE.Value
jencDocument = JE.object << jencTuplesDocument
jencTuplesDocument : Document -> List (String, JE.Value)
jencTuplesDocument x =
[ ("title", JE.string x.title)
, ("userKey", JE.string x.userKey)
[ ("id", JE.int x.id)
, ("title", JE.string x.title)
, ("content", JE.string x.content)
, ("tags", (JE.list << L.map (JE.string)) x.tags)
]
jdecDocument : JD.Decoder (Document )
jdecDocument =
("id" := JD.int) `JD.andThen` \j_id ->
("title" := JD.string) `JD.andThen` \j_title ->
("userKey" := JD.string) `JD.andThen` \j_userKey ->
("content" := JD.string) `JD.andThen` \j_content ->
("tags" := JD.list (JD.string)) `JD.andThen` \j_tags ->
JD.succeed (Document j_title j_userKey j_content j_tags)
JD.succeed (Document j_id j_title j_content j_tags)
@@ -1,16 +1,15 @@
import Html exposing (Html, Attribute, div, input, text)
import Html.App as Html
import Http as Http
import String
import Html.Attributes exposing (..)
import Html.Events exposing (onInput, onClick)
import String
import Json.Decode as Json -- exposing (..)
import Json.Decode.Extra exposing (..)
import Maybe as Maybe
import Document exposing (..)
import Task exposing (..)
import Html.App exposing (..)
main : Program Never
main = Html.App.program
{ init = model ! [fetchDocuments]
, update = update
@@ -27,11 +26,13 @@ userKey = "b4be5a63-eb40-439b-a2f3-ff480bd87884"
model : Model
model =
{ documents = [], message = "" }
{ documents = []
, message = ""
}
fetchDocuments : Cmd Action
fetchDocuments =
Http.get (Json.list jdecDocument) ("http://localhost:8080/documents/" ++ userKey)
Http.get (Json.list jdecDocument) ("http://localhost:8099/documents/" ++ userKey)
|> Task.mapError toString
|> Task.perform ErrorOccurred DocumentsFetched
@@ -68,13 +69,22 @@ documentListStyle =
[ ("list-style", "none")
]
documentListElement d = Html.li [] [text (d.title ++ " - " ++ d.content ++ " | ")]
documentListElement d =
Html.li [] [
text (d.title ++ " - "), decorateContent d.content
]
decorateContent c =
if String.contains "http" c then Html.a [href c] [text c]
else text c
view : Model -> Html Action
view model =
div []
[
div [] [ text model.message ]
, Html.button [ onClick FetchDocuments ] [ text "search documents" ]
, Html.input [ onClick FetchDocuments ] [ text "search documents" ]
, documentList model.documents
]
@@ -1,5 +1,6 @@
flags: {}
resolver: lts-6.10
packages:
- '.'
extra-deps: []
resolver: lts-3.4
flags: {}
extra-package-dbs: []

0 comments on commit c3cb781

Please sign in to comment.