module Main exposing (..) import Html exposing (Html, Attribute, div, input, text, li, ul, a, h4, label, i, span, hr, small, p) import Html.Attributes exposing (class, classList, id, type_, for, style) import Html.Events exposing (onClick) import WebSocket exposing (listen) import Json.Decode exposing (int, string, float, list, bool, Decoder) import Json.Encode import Json.Decode.Pipeline exposing (decode, required, optional, hardcoded) import Markdown main : Program Flags Model Msg main = Html.programWithFlags { init = init , view = view , update = update , subscriptions = subscriptions } scheduleServer : String scheduleServer = "ws://localhost:8000/schedule/" -- MODEL type alias Model = { days : List Day , eventInstances : List EventInstance , eventLocations : List EventLocation , eventTypes : List EventType , flags : Flags , activeDay : Day , filter : Filter , activeEventInstance : Maybe EventInstance } type alias Filter = { eventTypes : List EventType , eventLocations : List EventLocation } type alias Day = { day_name : String , iso : String , repr : String } type alias Speaker = { name : String , url : String } type alias EventInstance = { title : String , id : Int , url : String , abstract : String , eventSlug : String , eventType : String , backgroundColor : String , forgroundColor : String , from : String , to : String , timeslots : Float , location : String , locationIcon : String , speakers : List Speaker , videoRecording : Bool , videoUrl : String } type alias EventLocation = { name : String , slug : String , icon : String } type alias EventType = { name : String , slug : String , color : String , lightText : Bool } type alias Flags = { schedule_timeslot_length_minutes : Int , schedule_midnight_offset_hours : Int , ics_button_href : String , camp_slug : String } allDaysDay : Day allDaysDay = Day "All Days" "" "" init : Flags -> ( Model, Cmd Msg ) init flags = ( Model [] [] [] [] flags allDaysDay (Filter [] []) Nothing, sendInitMessage flags.camp_slug ) sendInitMessage : String -> Cmd Msg sendInitMessage camp_slug = WebSocket.send scheduleServer (Json.Encode.encode 0 (Json.Encode.object [ ( "action", Json.Encode.string "init" ) , ( "camp_slug", Json.Encode.string camp_slug ) ] ) ) -- UPDATE type Msg = NoOp | WebSocketPayload String | MakeActiveday Day | ToggleEventTypeFilter EventType | ToggleEventLocationFilter EventLocation | OpenEventInstanceDetail EventInstance | CloseEventInstanceDetail update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of NoOp -> ( model, Cmd.none ) WebSocketPayload str -> let newModel = case Json.Decode.decodeString initDataDecoder str of Ok m -> m model.flags allDaysDay (Filter [] []) Nothing Err error -> model in newModel ! [] MakeActiveday day -> { model | activeDay = day } ! [] ToggleEventTypeFilter eventType -> let eventTypesFilter = if List.member eventType model.filter.eventTypes then List.filter (\x -> x /= eventType) model.filter.eventTypes else eventType :: model.filter.eventTypes currentFilter = model.filter newFilter = { currentFilter | eventTypes = eventTypesFilter } in { model | filter = newFilter } ! [] ToggleEventLocationFilter eventLocation -> let eventLocationsFilter = if List.member eventLocation model.filter.eventLocations then List.filter (\x -> x /= eventLocation) model.filter.eventLocations else eventLocation :: model.filter.eventLocations currentFilter = model.filter newFilter = { currentFilter | eventLocations = eventLocationsFilter } in { model | filter = newFilter } ! [] OpenEventInstanceDetail eventInstance -> { model | activeEventInstance = Just eventInstance } ! [] CloseEventInstanceDetail -> { model | activeEventInstance = Nothing } ! [] -- SUBSCRIPTIONS subscriptions : Model -> Sub Msg subscriptions model = WebSocket.listen scheduleServer WebSocketPayload -- DECODERS dayDecoder : Decoder Day dayDecoder = decode Day |> required "day_name" string |> required "iso" string |> required "repr" string speakerDecoder : Decoder Speaker speakerDecoder = decode Speaker |> required "name" string |> required "url" string eventInstanceDecoder : Decoder EventInstance eventInstanceDecoder = decode EventInstance |> required "title" string |> required "id" int |> required "url" string |> required "abstract" string |> required "event_slug" string |> required "event_type" string |> required "bg-color" string |> required "fg-color" string |> required "from" string |> required "to" string |> required "timeslots" float |> required "location" string |> required "location_icon" string |> required "speakers" (list speakerDecoder) |> required "video_recording" bool |> optional "video_url" string "" eventLocationDecoder : Decoder EventLocation eventLocationDecoder = decode EventLocation |> required "name" string |> required "slug" string |> required "icon" string eventTypeDecoder : Decoder EventType eventTypeDecoder = decode EventType |> required "name" string |> required "slug" string |> required "color" string |> required "light_text" bool initDataDecoder : Decoder (Flags -> Day -> Filter -> Maybe EventInstance -> Model) initDataDecoder = decode Model |> required "days" (list dayDecoder) |> required "event_instances" (list eventInstanceDecoder) |> required "event_locations" (list eventLocationDecoder) |> required "event_types" (list eventTypeDecoder) -- VIEW dayButton : Day -> Day -> Html Msg dayButton day activeDay = a [ classList [ ( "btn", True ) , ( "btn-default", day /= activeDay ) , ( "btn-primary", day == activeDay ) ] , onClick (MakeActiveday day) ] [ text day.day_name ] view : Model -> Html Msg view model = div [] [ div [ class "row" ] [ div [ id "schedule-days", class "btn-group" ] (List.map (\day -> dayButton day model.activeDay) (allDaysDay :: model.days)) ] , hr [] [] , case model.activeEventInstance of Just eventInstance -> eventInstanceDetailView eventInstance Nothing -> scheduleOverviewView model ] eventInstanceDetailView : EventInstance -> Html Msg eventInstanceDetailView eventInstance = div [ class "row" ] [ div [ class "col-sm-9" ] [ div [ onClick CloseEventInstanceDetail ] [ text "Back" ] , h4 [] [ text eventInstance.title ] , p [] [ Markdown.toHtml [] eventInstance.abstract ] ] , div [ classList [ ( "col-sm-3", True ) , ( "schedule-sidebar", True ) ] ] [ h4 [] [ text "Speakers" ] ] ] scheduleOverviewView : Model -> Html Msg scheduleOverviewView model = div [ class "row" ] [ div [ classList [ ( "col-sm-3", True ) , ( "col-sm-push-9", True ) , ( "schedule-sidebar", True ) , ( "schedule-filter", True ) ] ] [ h4 [] [ text "Filter" ] , div [ class "form-group" ] [ filterView "Type" model.eventTypes model.filter.eventTypes ToggleEventTypeFilter , filterView "Location" model.eventLocations model.filter.eventLocations ToggleEventLocationFilter ] ] , div [ classList [ ( "col-sm-9", True ) , ( "col-sm-pull-3", True ) ] ] (List.map (\day -> dayRowView day model) model.days) ] dayRowView : Day -> Model -> Html Msg dayRowView day model = let types = List.map (\eventType -> eventType.slug) (if List.isEmpty model.filter.eventTypes then model.eventTypes else model.filter.eventTypes ) locations = List.map (\eventLocation -> eventLocation.slug) (if List.isEmpty model.filter.eventLocations then model.eventLocations else model.filter.eventLocations ) filteredEventInstances = List.filter (\eventInstance -> ((String.slice 0 10 eventInstance.from) == day.iso) && List.member eventInstance.location locations && List.member eventInstance.eventType types ) model.eventInstances in div [] [ h4 [] [ text day.repr ] , div [ class "schedule-day-row" ] (List.map dayEventInstanceView filteredEventInstances) ] dayEventInstanceView : EventInstance -> Html Msg dayEventInstanceView eventInstance = a [ class "event" , onClick (OpenEventInstanceDetail eventInstance) , style [ ( "background-color", eventInstance.backgroundColor ) , ( "color", eventInstance.forgroundColor ) ] ] [ small [] [ text ((String.slice 11 16 eventInstance.from) ++ " - " ++ (String.slice 11 16 eventInstance.to)) ] , i [ classList [ ( "fa", True ), ( "fa-" ++ eventInstance.locationIcon, True ), ( "pull-right", True ) ] ] [] , p [] [ text eventInstance.title ] ] filterView : String -> List { a | name : String } -> List { a | name : String } -> ({ a | name : String } -> Msg) -> Html Msg filterView name possibleFilters currentFilters action = div [] [ text (name ++ ":") , ul [] (List.map (\filter -> filterChoiceView filter currentFilters action) possibleFilters) ] filterChoiceView : { a | name : String } -> List { a | name : String } -> ({ a | name : String } -> Msg) -> Html Msg filterChoiceView filter currentFilters action = let active = List.member filter currentFilters notActive = not active in li [] [ div [ classList [ ( "btn", True ) , ( "btn-default", True ) , ( "filter-choice-active", active ) ] , onClick (action filter) ] [ span [] [ i [ classList [ ( "fa", True ), ( "fa-minus", active ), ( "fa-plus", notActive ) ] ] [] , text (" " ++ filter.name) ] ] ]