diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 117b100..3eb6a54 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -43,7 +43,8 @@ getPostListing c page = do let sub = ("subtext", toJSString $ fromSql subtext) let cat = ("category", toJSString category) let id = ("id", toJSString $ show $ (fromSql pid::Int)) - return $ showJSON $ toJSObject [id, title, sub, cat] + let catid = ("catid", toJSString $ fromSql cid) + return $ showJSON $ toJSObject [id, title, sub, cat, catid] ) result return $ Just $ showJSON $ JSArray posts @@ -75,7 +76,8 @@ getPostsInCategory c cat page = do let sub = ("subtext", toJSString $ fromSql subtext) let id = ("id", toJSString $ show $ (fromSql pid::Int)) let cat = ("category", toJSString category) - return $ showJSON $ toJSObject [id, cat, title, sub] + let catid = ("catid", toJSString $ fromSql cid) + return $ showJSON $ toJSObject [id, cat, title, sub, catid] ) result return $ Just $ showJSON $ toJSObject [("category", showJSON $ toJSString category), ("posts", showJSON $ JSArray posts)] @@ -92,7 +94,8 @@ getPostContent c pid = do let title = ("title", toJSString $ fromSql t) let content = ("content", toJSString $ fromSql con) let cat = ("category", toJSString category) - return $ Just $ showJSON $ toJSObject [title, content, cat]; + let catid = ("catid", toJSString $ fromSql cid) + return $ Just $ showJSON $ toJSObject [title, content, cat, catid]; _ -> fail "Post does not exist!" main :: IO () diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 5c57dc0..8d1fadc 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -1,15 +1,18 @@ module Main exposing (..) import Http -import Json.Decode exposing (Decoder, field, string, map2, map3, map4) +import Json.Decode exposing (Decoder, field, string, map2, map3, map4, map5) import Browser import Browser.Navigation exposing (..) import Url import Html exposing (..) import Html.Attributes exposing (..) +import Html.Events exposing (onInput, onClick) import Url.Parser as P exposing (()) +import Http exposing (multipartBody) +import Http exposing (stringPart) main : Program () Model Msg main = @@ -22,27 +25,16 @@ main = onUrlChange = UrlChanged } -type alias Post = { - id: String, - category: String, - title: String, - subtext: String - } - type alias Category = { id: String, name: String } -type alias Model = { - header: String, - content: String, - footer: String, - pinnedPosts: List Post, - posts: List Post, - route: Maybe Route, - key: Browser.Navigation.Key, - errMessage: Maybe (String) +type alias Post = { + id: String, + category: Category, + title: String, + subtext: String } type Route @@ -50,9 +42,9 @@ type Route | CategoriesView | CategoryView String | PostView String - | Login - | Logout - | CreatePost + | LoginView + | LogoutView + | CreatePostView routeParser : P.Parser (Route -> a) a routeParser = @@ -61,46 +53,15 @@ routeParser = , P.map CategoriesView (P.s "categories") , P.map CategoryView (P.s "category" P.string) , P.map PostView (P.s "post" P.string) - , P.map Login (P.s "login") - , P.map Logout (P.s "logout") - , P.map CreatePost (P.s "create") + , P.map LoginView (P.s "login") + , P.map LogoutView (P.s "logout") + , P.map CreatePostView (P.s "create") ] -messageOfRoute : Maybe Route -> Cmd Msg -messageOfRoute r = - case r of - Just route -> - case route of - Home -> Http.get {url = "/v1/posts", expect = Http.expectJson GotPosts processPostListing} - CategoriesView -> Http.get {url = "/v1/categories", expect = Http.expectJson GotCategories processCategoryListing} - PostView p -> Http.get {url = "/v1/post/" ++ p, expect = Http.expectJson GotPost processPost} - CategoryView c -> Http.get {url = "/v1/category/" ++ c, expect = Http.expectJson GotCategory processCategory} - _ -> Cmd.none - Nothing -> Cmd.none - -init : () -> Url.Url -> Browser.Navigation.Key -> (Model, Cmd Msg) -init _ url key = - let r = P.parse routeParser url in - ({ - header = "", content = "", footer = "", pinnedPosts = [], - posts = [], route = r, key = key, errMessage = Just "Loading Posts..." - }, - messageOfRoute r - ) - -type Msg - = LinkClinked Browser.UrlRequest - | UrlChanged Url.Url - | GotPosts (Result Http.Error (List Post)) - | GotCategories (Result Http.Error (List Category)) - | GotPost (Result Http.Error (String, String, String)) - | GotCategory (Result Http.Error (String, List Post)) - - processPostListing : Decoder (List Post) processPostListing = Json.Decode.list ( - map4 Post (field "id" string) (field "category" string) (field "title" string) (field "subtext" string) + map5(\a->\b->\c->\d->\e-> Post a (Category b c) d e) (field "id" string) (field "catid" string) (field "category" string) (field "title" string) (field "subtext" string) ) processCategoryListing : Decoder (List Category) @@ -115,6 +76,61 @@ processCategory : Decoder (String, List Post) processCategory = map2 (\a -> \b -> (a,b)) (field "category" string) (field "posts" processPostListing) +processLogin : Decoder (String) +processLogin = + (field "username" string) +messageOfRoute : Maybe Route -> Cmd Msg +messageOfRoute r = + case r of + Just route -> + case route of + Home -> Http.get {url = "/v1/posts", expect = Http.expectJson GotPosts processPostListing} + CategoriesView -> Http.get {url = "/v1/categories", expect = Http.expectJson GotCategories processCategoryListing} + PostView p -> Http.get {url = "/v1/post/" ++ p, expect = Http.expectJson GotPost processPost} + CategoryView c -> Http.get {url = "/v1/category/" ++ c, expect = Http.expectJson GotCategory processCategory} + _ -> Cmd.none + Nothing -> Cmd.none + +type alias User = { + username: String + } +type alias Model = { + header: String, + content: String, + footer: String, + pinnedPosts: List Post, + posts: List Post, + route: Maybe Route, + key: Browser.Navigation.Key, + errMessage: Maybe (String), + username: String, + password: String, + user: Maybe User + } + +type Msg + = LinkClinked Browser.UrlRequest + | UrlChanged Url.Url + | GotPosts (Result Http.Error (List Post)) + | GotCategories (Result Http.Error (List Category)) + | GotPost (Result Http.Error (String, String, String)) + | GotCategory (Result Http.Error (String, List Post)) + | LoginResult (Result Http.Error String) + | Username String + | Password String + | Login + +init : () -> Url.Url -> Browser.Navigation.Key -> (Model, Cmd Msg) +init _ url key = + let r = P.parse routeParser url in + ({ + header = "", content = "", footer = "", pinnedPosts = [], + posts = [], route = r, key = key, errMessage = Nothing, + username = "", password = "", user = Nothing + }, + messageOfRoute r + ) + update : Msg -> Model -> (Model, Cmd Msg) update msg model = case msg of @@ -130,8 +146,16 @@ update msg model = GotPosts (Ok l) -> ({model | errMessage = Nothing, posts = l}, Cmd.none) GotPosts (Err _) -> ({model | errMessage = Just "Failed to load posts"}, Cmd.none) GotPost (Ok (title, content, category)) -> ({model | errMessage = Nothing, header = title, content = content, footer = category}, Cmd.none) + GotCategory (Ok (title, posts)) -> ({model | errMessage = Nothing, header = title, posts = posts}, Cmd.none) + Username u -> ({model | username = u}, Cmd.none) + Password p -> ({model | password = p}, Cmd.none) + Login -> (model, handleLogin model) _ -> ({model | errMessage = Just "Something has gone horribly wrong."}, Cmd.none) +handleLogin : Model -> Cmd Msg +handleLogin model = + Http.post {url = "/v1/login", body = multipartBody [stringPart "username" model.username, stringPart "password" model.password], expect = Http.expectJson LoginResult processLogin} + type alias Document msg = { title: String, body: List (Html msg) @@ -139,12 +163,29 @@ type alias Document msg = { view : Model -> Document Msg view model = - {title = "Xnopyt.com", body = [htmlView model]} + {title = "XNOEBLOG", body = [htmlView model]} htmlView : Model -> Html Msg htmlView model = - renderModel model - + div [ + style "flex-direction" "column", + style "margin" "0", + style "padding" "0" + ] [ + div [ + style "border-bottom" "2px solid black", + style "height" "1.5em", + style "padding" "5px" + ] ([ + a [href "/"] [text "Home"], + text " - " + ] ++ + case model.user of + Nothing -> [a [href "/login"] [text "Login"]] + Just u -> [a [href "/logout"] [text "Logout"], text " - ", a [href "/create"] [text "Create Post"]] + ), + renderModel model + ] renderModel : Model -> Html Msg renderModel model = case (model.errMessage) of @@ -152,15 +193,23 @@ renderModel model = Nothing -> case model.route of Just route -> case route of - Home -> cardListing model - PostView _ -> div [] [h1 [] [text (model.header)], p [] [text(model.content)], h3 [] [text(model.footer), a [href "/"] [text "Go Home"]]] + Home -> div [] [h1 [] [text "Welcome to my blog."],cardListing model] + PostView _ -> div [] [h1 [] [text (model.header)], p [] [text(model.content)], h3 [] [text(model.footer ++ " ")]] + CategoryView _ -> div [] [h1 [] [text (model.header)], cardListing model] + LoginView -> loginForm model _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ] _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ] +cardListing : Model -> Html Msg +cardListing model = + div [ + style "display" "grid", + style "grid-template-columns" "repeat(auto-fill, minmax(16rem, 1fr))" + ] (List.map renderPost model.posts) renderPost : Post -> Html Msg renderPost post = div [ - style "width" "25%", + style "max-width" "32rem", style "height" "auto", style "box-sizing" "border-box", style "padding" "15px" @@ -169,12 +218,12 @@ renderPost post = style "flex-direction" "column", style "border-radius" "5px", style "display" "flex", - style "height" "100%" + style "height" "100%", + style "border" "2px solid black", + style "padding" "5px" ] [ header [ - style "background-color" "#404040", - style "color" "white", - style "height" "75px", + style "min-height" "75px", style "display" "flex", style "flex-direction" "column", style "align-items" "center", @@ -184,36 +233,38 @@ renderPost post = style "font-weight" "bold", style "border-radius" "10px 10px 0 0" ] [ - a [href ("/post/" ++ post.id)] [text (post.title)] + a [style "text-align" "center", href ("/post/" ++ post.id)] [text (post.title)] ], div [ - style "color" "white", style "flex-grow" "1", - style "background-color" "#505050", style "padding" "10px" ] [ text (post.subtext) ], footer [ - style "background-color" "#404040", - style "color" "white", - style "height" "50px", + style "min-height" "50px", style "display" "flex", style "flex-direction" "row", style "justify-content" "space-around", + style "align-items" "center", style "box-shadow" "none", style "box-sizing" "border-box", style "padding" "10px", style "border-radius" "0 0 10px 10px" ] [ - text (post.category) + text ("Category: "), a [href ("/category/" ++ post.category.id)] [text (post.category.name)] ] ] ] -cardListing : Model -> Html Msg -cardListing model = - div [ - style "display" "flex", - style "flex-flow" "row wrap" - ] (List.map renderPost model.posts) \ No newline at end of file +loginForm : Model -> Html Msg +loginForm model = + div [] [ + viewInput "text" "username" "Username" model.username Username, + viewInput "password" "password" "Password" model.password Password, + button [onClick Login] [text "Login"] + ] + +viewInput : String -> String -> String -> String -> (String -> msg) -> Html msg +viewInput t n p v toMsg = + input [ name n, type_ t, placeholder p, value v, onInput toMsg ] [] \ No newline at end of file