Skip to content

Instantly share code, notes, and snippets.

@battermann
Last active February 22, 2020 06:58
Show Gist options
  • Save battermann/11084d219f1a7cb492c7cd4394d02f5f to your computer and use it in GitHub Desktop.
Save battermann/11084d219f1a7cb492c7cd4394d02f5f to your computer and use it in GitHub Desktop.
module Main exposing (main)
import Bootstrap.CDN as CDN
import Bootstrap.Card as Card
import Bootstrap.Card.Block as Block
import Bootstrap.Form as Form
import Bootstrap.Form.Input as Input
import Bootstrap.Grid as Grid
import Bootstrap.Utilities.Spacing as Spacing
import Browser
import Html exposing (Html)
import Html.Events
import Http
import Iso8601
import Json.Encode as Encode
import Time exposing (Posix)
---- MODEL ----
type alias Model =
{ input : String
, tweets : List String
, timestamp : Maybe Posix
}
init : ( Model, Cmd Msg )
init =
( { input = "", tweets = [], timestamp = Nothing }, Cmd.none )
---- UPDATE ----
type Msg
= Input String
| Submit
| TweetResult (Result Http.Error ())
| Tick Posix
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
Input input ->
( { model | input = input }, Cmd.none )
Submit ->
( { model | input = "", tweets = model.input :: model.tweets }
, postTweet model.input (model.timestamp |> Maybe.map Iso8601.fromTime |> Maybe.withDefault "")
)
TweetResult (Ok _) ->
( model, Cmd.none )
TweetResult (Err _) ->
( model, Cmd.none )
Tick posix ->
( { model | timestamp = Just posix }, Cmd.none )
---- HTTP ----
postTweet : String -> String -> Cmd Msg
postTweet content timestamp =
Http.post
{ url = "http://localhost:8080/api/tweet"
, body =
Http.jsonBody
(Encode.object
[ ( "content", Encode.string content )
, ( "timestamp", Encode.string timestamp )
]
)
, expect = Http.expectWhatever TweetResult
}
---- VIEW ----
viewTweet : String -> Html Msg
viewTweet text =
Card.config [ Card.attrs [ Spacing.mb3 ] ]
|> Card.block [] [ Block.text [] [ Html.text text ] ]
|> Card.view
viewTweets : Model -> Html Msg
viewTweets model =
Html.div [] (model.tweets |> List.map viewTweet)
view : Model -> Html Msg
view model =
Grid.container []
[ CDN.stylesheet -- creates an inline style node with the Bootstrap CSS
, Grid.row []
[ Grid.col []
[ Form.form [ Html.Events.onSubmit Submit, Spacing.mt5 ]
[ Form.group []
[ Input.text
[ Input.id "eventname"
, Input.onInput Input
, Input.value model.input
, Input.placeholder "Tweet"
]
]
]
, viewTweets model
]
]
]
---- PROGRAM ----
main : Program () Model Msg
main =
Browser.element
{ view = view
, init = always init
, update = update
, subscriptions = always (Time.every 1000 Tick)
}
module Reducer where
import Prelude
import Affjax as AX
import Affjax as Ax
import Affjax.RequestBody as RequestBody
import Affjax.ResponseFormat as ResponseFormat
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (traverse_)
import Data.Formatter.DateTime (formatDateTime)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Now as Now
import React.Basic.DOM as R
import React.Basic.DOM.Events (preventDefault, stopPropagation, targetValue)
import React.Basic.Events (handler)
import React.Basic.Hooks (ReactComponent, component, element, memo, useReducer, useState, (/\))
import React.Basic.Hooks as React
import React.Basic.Hooks.Aff (useAff)
import Simple.JSON as JSON
data Action
= SendTweet String
type Tweet
= { content :: String
}
type TweetWithTs
= { content :: String
, timestamp :: String
}
type State
= { posted :: Maybe Tweet
, tweets :: Array Tweet
}
reducer :: State -> Action -> State
reducer state (SendTweet content) = state { posted = Just { content }, tweets = Array.cons { content } state.tweets }
mkReducer :: String -> Effect (ReactComponent {})
mkReducer url = do
let
initialState = { posted: Nothing, tweets: [] }
tweetInput <- memo mkTweetInput
tweetRow <- memo mkTweetRow
component "Tweets" \props -> React.do
state /\ dispatch <- useReducer initialState reducer
-- There is probably a way to use just one hook for posting & updating state, haven't figured out though
useAff state do
liftEffect $ log $ "State: " <> (show state)
case state.posted of
Just tweet -> do
maybeTs <- (formatDateTime "YYYY-MM-DDTHH:mm:ssZ") <$> Now.nowDateTime # liftEffect
maybeResponse <- case maybeTs of
Right ts -> AX.post ResponseFormat.string (url <> "/api/tweet") (Just (RequestBody.string (JSON.writeJSON { content: tweet.content, timestamp: ts }))) <#> lmap (Ax.printError)
Left err -> pure $ Left err
case maybeResponse of
Left err -> liftEffect $ log $ "Failed to post tweet" <> err
Right response -> liftEffect $ log $ show response.body
Nothing -> pure unit
pure
$ R.div
{ children:
[ element tweetInput { dispatch }
, R.div_
$ flip map state.tweets \tweet ->
element tweetRow { tweet }
]
, className: "container"
}
mkTweetInput :: Effect (ReactComponent { dispatch :: Action -> Effect Unit })
mkTweetInput = do
component "TweetInput" \props -> React.do
value /\ setValue <- useState ""
pure
$ R.form
{ onSubmit:
handler (preventDefault >>> stopPropagation) \_ -> do
props.dispatch $ SendTweet value
setValue $ const ""
, children:
[ R.input
{ value
, onChange:
handler (preventDefault >>> stopPropagation >>> targetValue)
$ traverse_ (setValue <<< const)
, className: "tweet"
, placeholder: "Tweet something"
}
]
, className: "tweet"
}
mkTweetRow :: Effect (ReactComponent { tweet :: Tweet })
mkTweetRow =
component "Tweet" \props -> React.do
pure
$ R.div
{ children:
[ R.label
{ children:
[ R.text props.tweet.content
]
, className: "tweet"
}
]
, className: "tweet"
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment