Repository: eeue56/servelm Branch: master Commit: 78b147a7836e Files: 21 Total size: 48.9 KB Directory structure: gitextract_5yerz_kn/ ├── .gitignore ├── LICENSE ├── README.md ├── elm-package.json ├── example/ │ ├── client/ │ │ ├── App.elm │ │ ├── HomepageStylesheet.elm │ │ ├── Stylesheets.elm │ │ └── elm-package.json │ ├── elm-package.json │ ├── run.sh │ └── server/ │ ├── Main.elm │ └── ServerSideClient/ │ ├── App.elm │ ├── HomepageStylesheet.elm │ └── Stylesheets.elm └── src/ ├── Http/ │ ├── Listeners.elm │ ├── Request.elm │ ├── Response/ │ │ └── Write.elm │ ├── Response.elm │ └── Server.elm └── Native/ ├── Http/ │ └── Response/ │ └── Write.js └── Http.js ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ example/*.js elm-stuff/ .DS_Store node_modules/ elm.js .comp ================================================ FILE: LICENSE ================================================ The MIT License (MIT) Copyright (c) 2015 Isaac Shapira Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: README.md ================================================ # Servelm - Elm Http Server # Deprecated. Server side elm is not designed to work this way. This server, along with rtfeldman's Elm stylesheets, means that we can now have full stack Elm support. At no point in the development of an application will you have to write anything other than Elm! It now supports server-side rendering of elm-html. A demo can be found [here](http://107.170.81.176/). The styling is done through compile-time correct CSS provided by [elm-stylesheets](https://github.com/rtfeldman/elm-stylesheets). # APIs exposed The Http.Server module allows you to create servers and run them. ## Sending out Elm Use the `Http.Response.writeElm` function to compile an Elm file on request. It will compile an Elm file found with `name + ".elm""`. It will write the output to a file in the same folder as `name + ".html"`. This will then be served out to the client. There is basic caching involved at the moment, which works based on the lifecycle of the server. Restart the server if you make any changes. This is enabled by the [node-elm-compiler](https://github.com/rtfeldman/node-elm-compiler) package. It also supports server-side rendering of elm-html, through using the [vdom-to-html](https://github.com/nthtran/vdom-to-html) package. ## Get started To start Elm inside of Node simply this to the end of your compiled Elm code. ```JavaScript Elm.worker(Elm.Main); ``` Take a look at `example/run.sh` to see a complete usage ```bash elm make example/server/Main.elm --output=example/main.js echo "Elm.worker(Elm.Main);" >> example/main.js node example/main.js ``` ## Run the example This project depends on Node.js and the `node` command. ```bash example/run.sh ``` Then load up the browser to see it working! # Credit Originally inspired by https://github.com/Fresheyeball/elm-http-server. There was some great work already there, I just cleaned it up a little and integrated it with some other packages. ================================================ FILE: elm-package.json ================================================ { "version": "1.0.0", "summary": "", "repository": "https://github.com/eeue56/servelm.git", "license": "MIT", "source-directories": [ "src/", "example/", "example/server/" ], "exposed-modules": [ "Http" ], "native-modules": true, "dependencies": { "elm-lang/core": "2.1.0 <= v < 3.0.0", "evancz/elm-html": "4.0.1 <= v < 5.0.0", "evancz/virtual-dom": "2.1.0 <= v < 3.0.0" }, "elm-version": "0.15.1 <= v < 0.16.0" } ================================================ FILE: example/client/App.elm ================================================ module App where import Html exposing (..) import Html.Attributes exposing (id, src, href) import HomepageStylesheet exposing (..) import Stylesheets import Json.Encode as Encode main : Html main = div [ id "dave" ] [ div [ Html.Attributes.property "innerHTML" (Encode.string ("")) ] [], div [ ] [ a [ href "/App.elm" ] [ text "This site was entirely written in Elm! Try /App.elm to see the source for this page!" ] ] ] ================================================ FILE: example/client/HomepageStylesheet.elm ================================================ module HomepageStylesheet where import Stylesheets exposing (..) exports = css |%| body |-| backgroundColor (rgb 173 191 160) |-| boxSizing borderBox |-| padding 12 px ================================================ FILE: example/client/Stylesheets.elm ================================================ module Stylesheets where {- Implementation notes: - strip out []()""'' - so: - toString ["html", "body"] -> "[\"html\",\"body\"]" -> "html,body" How would you write this? html, body, .foo, .bar width: 100% -} import String prettyPrint : Int -> Style class id -> String prettyPrint = prettyPrintHelp 0 prettyPrintHelp : Int -> Int -> Style class id -> String prettyPrintHelp indentLevel indentSpaces (Style selector attributes children) = if (indentLevel == 0) && (String.isEmpty selector) then children |> List.map (prettyPrintHelp indentLevel indentSpaces) |> String.join "\n\n" else let indentStr = String.repeat (indentSpaces * indentLevel) " " subIndentStr = indentStr ++ String.repeat (indentSpaces) " " attrsStr = if List.isEmpty attributes then "" else attributes |> List.map attributeToString |> String.join subIndentStr |> (++) subIndentStr prettyPrintChild = prettyPrintHelp (indentLevel + 1) indentSpaces childrenStr = if List.isEmpty children then "" else children |> List.map prettyPrintChild |> String.join subIndentStr |> (++) subIndentStr in indentStr ++ selector ++ " {\n" ++ attrsStr ++ childrenStr ++ "}" attributeToString : Attribute -> String attributeToString (Attribute str) = str ++ ";\n" {- Tags -} html = Tag "html" body = Tag "body" header = Tag "header" nav = Tag "nav" div = Tag "div" span = Tag "span" img = Tag "img" nowrap = Tag "nowrap" button = Tag "button" h1 = Tag "h1" h2 = Tag "h2" h3 = Tag "h3" h4 = Tag "h4" p = Tag "p" ol = Tag "ol" input = Tag "input" tagToString (Tag str) = str -- TODO these are just for @media - maybe improve type guarantees? screen = "screen" print = "print" -- TODO this is just for ::selection - maybe improve type guarantees? selection = "selection" {- Units -} inheritToString : (a -> String) -> InheritOr a -> String inheritToString translate value = case value of Inherit -> "inherit" NotInherit notInherit -> translate notInherit autoToString : (a -> String) -> AutoOr a -> String autoToString translate value = case value of Auto -> "auto" NotAuto notAuto -> translate notAuto noneToString : (a -> String) -> NoneOr a -> String noneToString translate value = case value of None -> "none" NotNone notNone -> translate notNone unitsToString : Units -> String unitsToString = (\(ExplicitUnits str) -> str) |> inheritToString boxSizingToString : BoxSizing -> String boxSizingToString = (\(ExplicitBoxSizing str) -> str) |> inheritToString overflowToString : Overflow -> String overflowToString = (\(ExplicitOverflow str) -> str) |> autoToString |> inheritToString displayToString : Display -> String displayToString = (\(ExplicitDisplay str) -> str) |> noneToString |> inheritToString verticalAlignToString : VerticalAlign -> String verticalAlignToString = (\(ExplicitVerticalAlign str) -> str) |> inheritToString whiteSpaceToString : WhiteSpace -> String whiteSpaceToString = (\(ExplicitWhiteSpace str) -> str) |> autoToString |> inheritToString colorToString : Color -> String colorToString = (\(ExplicitColor str) -> str) |> autoToString |> inheritToString numberToString : number -> String numberToString num = toString (num + 0) textShadowToString : TextShadow -> String textShadowToString = explicitTextShadowToString |> noneToString |> inheritToString explicitTextShadowToString : ExplicitTextShadow -> String explicitTextShadowToString value = case value of NoTextShadow -> "TODO" outlineStyleToString : OutlineStyle -> String outlineStyleToString (OutlineStyle str) = str opacityStyleToString : OpacityStyle -> String opacityStyleToString (OpacityStyle str) = str type Tag = Tag String type InheritOr a = Inherit | NotInherit a type AutoOr a = Auto | NotAuto a type NoneOr a = None | NotNone a type alias BoxSizing = InheritOr ExplicitBoxSizing type alias Overflow = InheritOr (AutoOr ExplicitOverflow) type alias Display = InheritOr (NoneOr ExplicitDisplay) type alias WhiteSpace = InheritOr (AutoOr ExplicitWhiteSpace) type alias Color = InheritOr (AutoOr ExplicitColor) type alias TextShadow = InheritOr (NoneOr ExplicitTextShadow) type alias Outline = InheritOr ExplicitOutline type alias Units = InheritOr ExplicitUnits type alias VerticalAlign = InheritOr ExplicitVerticalAlign type ExplicitUnits = ExplicitUnits String type ExplicitBoxSizing = ExplicitBoxSizing String type ExplicitOverflow = ExplicitOverflow String type ExplicitDisplay = ExplicitDisplay String type ExplicitWhiteSpace = ExplicitWhiteSpace String type ExplicitColor = ExplicitColor String type ExplicitVerticalAlign = ExplicitVerticalAlign String type ExplicitOutline = ExplicitOutline Float ExplicitUnits OutlineStyle OpacityStyle type OutlineStyle = OutlineStyle String type OpacityStyle = OpacityStyle String type ExplicitTextShadow = NoTextShadow solid : OutlineStyle solid = OutlineStyle "solid" transparent : OpacityStyle transparent = OpacityStyle "transparent" rgb : number -> number -> number -> Color rgb r g b = ExplicitColor ("rgb(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ")") |> NotAuto |> NotInherit rgba : number -> number -> number -> number -> Color rgba r g b a = ExplicitColor ("rgba(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ", " ++ (numberToString a) ++ ")") |> NotAuto |> NotInherit hex : String -> Color hex str = ExplicitColor ("#" ++ str) |> NotAuto |> NotInherit pct : Units pct = "%" |> ExplicitUnits |> NotInherit em : Units em = "em" |> ExplicitUnits |> NotInherit px : Units px = "px" |> ExplicitUnits |> NotInherit borderBox = "border-box" |> ExplicitBoxSizing |> NotInherit visible : Display visible = "visible" |> ExplicitDisplay |> NotNone |> NotInherit block : Display block = "block" |> ExplicitDisplay |> NotNone |> NotInherit inlineBlock : Display inlineBlock = "inline-block" |> ExplicitDisplay |> NotNone |> NotInherit inline : Display inline = "inline" |> ExplicitDisplay |> NotNone |> NotInherit none : InheritOr (NoneOr a) none = None |> NotInherit auto : InheritOr (AutoOr a) auto = Auto |> NotInherit inherit : InheritOr a inherit = Inherit noWrap : WhiteSpace noWrap = "no-wrap" |> ExplicitWhiteSpace |> NotAuto |> NotInherit top : VerticalAlign top = "top" |> ExplicitVerticalAlign |> NotInherit middle : VerticalAlign middle = "middle" |> ExplicitVerticalAlign |> NotInherit bottom : VerticalAlign bottom = "bottom" |> ExplicitVerticalAlign |> NotInherit {- Attributes -} attr1 name translate value = Attribute (name ++ ": " ++ (translate value)) attr2 name translateA translateB valueA valueB = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB)) attr3 name translateA translateB translateC valueA valueB valueC = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC)) attr4 name translateA translateB translateC translateD valueA valueB valueC valueD = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD)) attr5 name translateA translateB translateC translateD translateE valueA valueB valueC valueD valueE = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD) ++ (translateE valueE)) verticalAlign : VerticalAlign -> Attribute verticalAlign = attr1 "vertical-align" verticalAlignToString display : Display -> Attribute display = attr1 "display" displayToString opacity : OpacityStyle -> Attribute opacity = attr1 "opacity" toString width : number -> Units -> Attribute width = attr2 "width" numberToString unitsToString minWidth : number -> Units -> Attribute minWidth = attr2 "min-width" numberToString unitsToString height : number -> Units -> Attribute height = attr2 "height" numberToString unitsToString minHeight : number -> Units -> Attribute minHeight = attr2 "min-height" numberToString unitsToString padding : number -> Units -> Attribute padding = attr2 "padding" numberToString unitsToString paddingTop : number -> Units -> Attribute paddingTop = attr2 "padding-top" numberToString unitsToString paddingBottom : number -> Units -> Attribute paddingBottom = attr2 "padding-bottom" numberToString unitsToString paddingRight : number -> Units -> Attribute paddingRight = attr2 "padding-right" numberToString unitsToString paddingLeft : number -> Units -> Attribute paddingLeft = attr2 "padding-left" numberToString unitsToString margin : number -> Units -> Attribute margin = attr2 "margin" numberToString unitsToString marginTop : number -> Units -> Attribute marginTop = attr2 "margin-top" numberToString unitsToString marginBottom : number -> Units -> Attribute marginBottom = attr2 "margin-bottom" numberToString unitsToString marginRight : number -> Units -> Attribute marginRight = attr2 "margin-right" numberToString unitsToString marginLeft : number -> Units -> Attribute marginLeft = attr2 "margin-left" numberToString unitsToString boxSizing : BoxSizing -> Attribute boxSizing = attr1 "box-sizing" boxSizingToString overflowX : Overflow -> Attribute overflowX = attr1 "overflow-x" overflowToString overflowY : Overflow -> Attribute overflowY = attr1 "overflow-y" overflowToString whiteSpace : WhiteSpace -> Attribute whiteSpace = attr1 "white-space" whiteSpaceToString backgroundColor : Color -> Attribute backgroundColor = attr1 "background-color" colorToString color : Color -> Attribute color = attr1 "color" colorToString media : a -> String media value = "media " ++ (toString value) -- TODO textShadow : TextShadow -> Attribute textShadow = attr1 "text-shadow" textShadowToString outline : Float -> Units -> OutlineStyle -> OpacityStyle -> Attribute outline = attr4 "outline" toString unitsToString (\str -> " " ++ outlineStyleToString str ++ " ") opacityStyleToString {- Types -} type Style class id = Style String (List Attribute) (List (Style class id)) type Attribute = Attribute String css : Style class id css = Style "" [] [] styleWithPrefix : String -> Style class id -> a -> Style class id styleWithPrefix prefix (Style selector attrs children) childSelector = children ++ [ Style (prefix ++ (toString childSelector)) [] [] ] |> Style selector attrs (|%|) : Style class id -> Tag -> Style class id (|%|) (Style selector attrs children) tag = children ++ [ Style (tagToString tag) [] [] ] |> Style selector attrs (|%|=) : Style class id -> List Tag -> Style class id (|%|=) (Style selector attrs children) tags = let childSelector = tags |> List.map tagToString |> String.join ", " in children ++ [ Style childSelector [] [] ] |> Style selector attrs (|@|) : Style class id -> a -> Style class id (|@|) = styleWithPrefix "@" (|::|) : Style class id -> a -> Style class id (|::|) = styleWithPrefix "::" (|>%|) : Style class id -> Tag -> Style class id (|>%|) (Style selector attrs children) tag = case splitStartLast children of ( _, Nothing ) -> children ++ [ Style (selector ++ " > " ++ tagToString tag) [] [] ] |> Style selector attrs ( start, Just (Style activeSelector _ _) ) -> children ++ [ Style (activeSelector ++ " > " ++ tagToString tag) [] [] ] |> Style selector attrs (|>%|=) : Style class id -> List Tag -> Style class id (|>%|=) (Style selector attrs children) tags = let selectorFromTag tag = case splitStartLast children of ( _, Nothing ) -> selector ++ " > " ++ tagToString tag ( start, Just (Style activeSelector _ _) ) -> activeSelector ++ " > " ++ tagToString tag childSelector = tags |> List.map selectorFromTag |> String.join ", " in children ++ [ Style childSelector [] [] ] |> Style selector attrs (|.|) : Style class id -> class -> Style class id (|.|) = styleWithPrefix "." (|#|) : Style class id -> id -> Style class id (|#|) = styleWithPrefix "#" (|>.|) : Style class id -> a -> Style class id (|>.|) = styleWithPrefix ">." (|!|) : Style class id -> Attribute -> Style class id (|!|) style (Attribute attrString) = transformActiveChild (addAttr (Attribute (attrString ++ " !important"))) style (|-|) : Style class id -> Attribute -> Style class id (|-|) style attr = transformActiveChild (addAttr attr) style addAttr : Attribute -> Style a b -> Style a b addAttr attr (Style selector attrs children) = Style selector (attrs ++ [ attr ]) children transformActiveChild : (Style a b -> Style a b) -> Style a b -> Style a b transformActiveChild transform (( Style selector attrs children ) as style) = case splitStartLast children of ( _, Nothing ) -> transform style ( inactiveChildren, Just activeChild ) -> Style selector attrs (inactiveChildren ++ [ transform activeChild ]) splitStartLast : List a -> (List a, Maybe a) splitStartLast list = case list of [] -> ( [], Nothing ) elem :: [] -> ( [], Just elem ) elem :: rest -> let ( start, last ) = splitStartLast rest in ( elem :: start, last ) ================================================ FILE: example/client/elm-package.json ================================================ { "version": "1.0.0", "summary": "helpful summary of your project, less than 80 characters", "repository": "https://github.com/USER/PROJECT.git", "license": "BSD3", "source-directories": [ "." ], "exposed-modules": [], "dependencies": { "elm-lang/core": "2.1.0 <= v < 3.0.0", "evancz/elm-html": "4.0.1 <= v < 5.0.0" }, "elm-version": "0.15.1 <= v < 0.16.0" } ================================================ FILE: example/elm-package.json ================================================ { "version": "1.0.0", "summary": "helpful summary of your project, less than 80 characters", "repository": "https://github.com/USER/PROJECT.git", "license": "BSD3", "source-directories": [ ".", "server/", "server/Client" ], "exposed-modules": [], "dependencies": { "elm-lang/core": "2.1.0 <= v < 3.0.0", "evancz/elm-html": "4.0.1 <= v < 5.0.0" }, "elm-version": "0.15.1 <= v < 0.16.0" } ================================================ FILE: example/run.sh ================================================ elm make example/server/Main.elm --output=example/main.js echo "Elm.worker(Elm.Main);" >> example/main.js node example/main.js ================================================ FILE: example/server/Main.elm ================================================ module Main where import Http.Server exposing (..) import Http.Request exposing (emptyReq, Request, Method(..)) import Http.Response exposing (emptyRes, Response) import Http.Response.Write exposing ( writeHtml, writeJson , writeElm, writeFile , writeNode) import Task exposing (..) import Signal exposing (..) import Json.Encode as Json import ServerSideClient.App exposing (main) server : Mailbox (Request, Response) server = mailbox (emptyReq, emptyRes) route : (Request, Response) -> Task x () route (req, res) = case req.method of GET -> case req.url of "/" -> writeElm "/client/App" res "/App.elm" -> writeFile "/client/App.elm" res "/foo" -> writeHtml "

Foozle!

" res "/bar" -> writeNode main res url -> writeHtml ("You tried to go to " ++ url) res POST -> res |> writeJson (Json.object [("foo", Json.string "bar")]) NOOP -> succeed () _ -> res |> writeJson (Json.string "unknown method!") port reply : Signal (Task x ()) port reply = route <~ dropRepeats server.signal port serve : Task x Server port serve = createServer' server.address 8080 "Listening on 8080" ================================================ FILE: example/server/ServerSideClient/App.elm ================================================ module ServerSideClient.App where import Html exposing (..) import Html.Attributes exposing (id, src, href) import ServerSideClient.HomepageStylesheet exposing (exports) import ServerSideClient.Stylesheets as Stylesheets import Json.Encode as Encode main : Html main = div [ id "dave" ] [ div [ Html.Attributes.property "innerHTML" (Encode.string ("")) ] [], div [ ] [ text "This page was rendered on the server!" ] ] ================================================ FILE: example/server/ServerSideClient/HomepageStylesheet.elm ================================================ module ServerSideClient.HomepageStylesheet where import ServerSideClient.Stylesheets exposing (..) exports = css |%| body |-| backgroundColor (rgb 173 191 160) |-| boxSizing borderBox |-| padding 12 px ================================================ FILE: example/server/ServerSideClient/Stylesheets.elm ================================================ module ServerSideClient.Stylesheets where {- Implementation notes: - strip out []()""'' - so: - toString ["html", "body"] -> "[\"html\",\"body\"]" -> "html,body" How would you write this? html, body, .foo, .bar width: 100% -} import String prettyPrint : Int -> Style class id -> String prettyPrint = prettyPrintHelp 0 prettyPrintHelp : Int -> Int -> Style class id -> String prettyPrintHelp indentLevel indentSpaces (Style selector attributes children) = if (indentLevel == 0) && (String.isEmpty selector) then children |> List.map (prettyPrintHelp indentLevel indentSpaces) |> String.join "\n\n" else let indentStr = String.repeat (indentSpaces * indentLevel) " " subIndentStr = indentStr ++ String.repeat (indentSpaces) " " attrsStr = if List.isEmpty attributes then "" else attributes |> List.map attributeToString |> String.join subIndentStr |> (++) subIndentStr prettyPrintChild = prettyPrintHelp (indentLevel + 1) indentSpaces childrenStr = if List.isEmpty children then "" else children |> List.map prettyPrintChild |> String.join subIndentStr |> (++) subIndentStr in indentStr ++ selector ++ " {\n" ++ attrsStr ++ childrenStr ++ "}" attributeToString : Attribute -> String attributeToString (Attribute str) = str ++ ";\n" {- Tags -} html = Tag "html" body = Tag "body" header = Tag "header" nav = Tag "nav" div = Tag "div" span = Tag "span" img = Tag "img" nowrap = Tag "nowrap" button = Tag "button" h1 = Tag "h1" h2 = Tag "h2" h3 = Tag "h3" h4 = Tag "h4" p = Tag "p" ol = Tag "ol" input = Tag "input" tagToString (Tag str) = str -- TODO these are just for @media - maybe improve type guarantees? screen = "screen" print = "print" -- TODO this is just for ::selection - maybe improve type guarantees? selection = "selection" {- Units -} inheritToString : (a -> String) -> InheritOr a -> String inheritToString translate value = case value of Inherit -> "inherit" NotInherit notInherit -> translate notInherit autoToString : (a -> String) -> AutoOr a -> String autoToString translate value = case value of Auto -> "auto" NotAuto notAuto -> translate notAuto noneToString : (a -> String) -> NoneOr a -> String noneToString translate value = case value of None -> "none" NotNone notNone -> translate notNone unitsToString : Units -> String unitsToString = (\(ExplicitUnits str) -> str) |> inheritToString boxSizingToString : BoxSizing -> String boxSizingToString = (\(ExplicitBoxSizing str) -> str) |> inheritToString overflowToString : Overflow -> String overflowToString = (\(ExplicitOverflow str) -> str) |> autoToString |> inheritToString displayToString : Display -> String displayToString = (\(ExplicitDisplay str) -> str) |> noneToString |> inheritToString verticalAlignToString : VerticalAlign -> String verticalAlignToString = (\(ExplicitVerticalAlign str) -> str) |> inheritToString whiteSpaceToString : WhiteSpace -> String whiteSpaceToString = (\(ExplicitWhiteSpace str) -> str) |> autoToString |> inheritToString colorToString : Color -> String colorToString = (\(ExplicitColor str) -> str) |> autoToString |> inheritToString numberToString : number -> String numberToString num = toString (num + 0) textShadowToString : TextShadow -> String textShadowToString = explicitTextShadowToString |> noneToString |> inheritToString explicitTextShadowToString : ExplicitTextShadow -> String explicitTextShadowToString value = case value of NoTextShadow -> "TODO" outlineStyleToString : OutlineStyle -> String outlineStyleToString (OutlineStyle str) = str opacityStyleToString : OpacityStyle -> String opacityStyleToString (OpacityStyle str) = str type Tag = Tag String type InheritOr a = Inherit | NotInherit a type AutoOr a = Auto | NotAuto a type NoneOr a = None | NotNone a type alias BoxSizing = InheritOr ExplicitBoxSizing type alias Overflow = InheritOr (AutoOr ExplicitOverflow) type alias Display = InheritOr (NoneOr ExplicitDisplay) type alias WhiteSpace = InheritOr (AutoOr ExplicitWhiteSpace) type alias Color = InheritOr (AutoOr ExplicitColor) type alias TextShadow = InheritOr (NoneOr ExplicitTextShadow) type alias Outline = InheritOr ExplicitOutline type alias Units = InheritOr ExplicitUnits type alias VerticalAlign = InheritOr ExplicitVerticalAlign type ExplicitUnits = ExplicitUnits String type ExplicitBoxSizing = ExplicitBoxSizing String type ExplicitOverflow = ExplicitOverflow String type ExplicitDisplay = ExplicitDisplay String type ExplicitWhiteSpace = ExplicitWhiteSpace String type ExplicitColor = ExplicitColor String type ExplicitVerticalAlign = ExplicitVerticalAlign String type ExplicitOutline = ExplicitOutline Float ExplicitUnits OutlineStyle OpacityStyle type OutlineStyle = OutlineStyle String type OpacityStyle = OpacityStyle String type ExplicitTextShadow = NoTextShadow solid : OutlineStyle solid = OutlineStyle "solid" transparent : OpacityStyle transparent = OpacityStyle "transparent" rgb : number -> number -> number -> Color rgb r g b = ExplicitColor ("rgb(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ")") |> NotAuto |> NotInherit rgba : number -> number -> number -> number -> Color rgba r g b a = ExplicitColor ("rgba(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ", " ++ (numberToString a) ++ ")") |> NotAuto |> NotInherit hex : String -> Color hex str = ExplicitColor ("#" ++ str) |> NotAuto |> NotInherit pct : Units pct = "%" |> ExplicitUnits |> NotInherit em : Units em = "em" |> ExplicitUnits |> NotInherit px : Units px = "px" |> ExplicitUnits |> NotInherit borderBox = "border-box" |> ExplicitBoxSizing |> NotInherit visible : Display visible = "visible" |> ExplicitDisplay |> NotNone |> NotInherit block : Display block = "block" |> ExplicitDisplay |> NotNone |> NotInherit inlineBlock : Display inlineBlock = "inline-block" |> ExplicitDisplay |> NotNone |> NotInherit inline : Display inline = "inline" |> ExplicitDisplay |> NotNone |> NotInherit none : InheritOr (NoneOr a) none = None |> NotInherit auto : InheritOr (AutoOr a) auto = Auto |> NotInherit inherit : InheritOr a inherit = Inherit noWrap : WhiteSpace noWrap = "no-wrap" |> ExplicitWhiteSpace |> NotAuto |> NotInherit top : VerticalAlign top = "top" |> ExplicitVerticalAlign |> NotInherit middle : VerticalAlign middle = "middle" |> ExplicitVerticalAlign |> NotInherit bottom : VerticalAlign bottom = "bottom" |> ExplicitVerticalAlign |> NotInherit {- Attributes -} attr1 name translate value = Attribute (name ++ ": " ++ (translate value)) attr2 name translateA translateB valueA valueB = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB)) attr3 name translateA translateB translateC valueA valueB valueC = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC)) attr4 name translateA translateB translateC translateD valueA valueB valueC valueD = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD)) attr5 name translateA translateB translateC translateD translateE valueA valueB valueC valueD valueE = Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD) ++ (translateE valueE)) verticalAlign : VerticalAlign -> Attribute verticalAlign = attr1 "vertical-align" verticalAlignToString display : Display -> Attribute display = attr1 "display" displayToString opacity : OpacityStyle -> Attribute opacity = attr1 "opacity" toString width : number -> Units -> Attribute width = attr2 "width" numberToString unitsToString minWidth : number -> Units -> Attribute minWidth = attr2 "min-width" numberToString unitsToString height : number -> Units -> Attribute height = attr2 "height" numberToString unitsToString minHeight : number -> Units -> Attribute minHeight = attr2 "min-height" numberToString unitsToString padding : number -> Units -> Attribute padding = attr2 "padding" numberToString unitsToString paddingTop : number -> Units -> Attribute paddingTop = attr2 "padding-top" numberToString unitsToString paddingBottom : number -> Units -> Attribute paddingBottom = attr2 "padding-bottom" numberToString unitsToString paddingRight : number -> Units -> Attribute paddingRight = attr2 "padding-right" numberToString unitsToString paddingLeft : number -> Units -> Attribute paddingLeft = attr2 "padding-left" numberToString unitsToString margin : number -> Units -> Attribute margin = attr2 "margin" numberToString unitsToString marginTop : number -> Units -> Attribute marginTop = attr2 "margin-top" numberToString unitsToString marginBottom : number -> Units -> Attribute marginBottom = attr2 "margin-bottom" numberToString unitsToString marginRight : number -> Units -> Attribute marginRight = attr2 "margin-right" numberToString unitsToString marginLeft : number -> Units -> Attribute marginLeft = attr2 "margin-left" numberToString unitsToString boxSizing : BoxSizing -> Attribute boxSizing = attr1 "box-sizing" boxSizingToString overflowX : Overflow -> Attribute overflowX = attr1 "overflow-x" overflowToString overflowY : Overflow -> Attribute overflowY = attr1 "overflow-y" overflowToString whiteSpace : WhiteSpace -> Attribute whiteSpace = attr1 "white-space" whiteSpaceToString backgroundColor : Color -> Attribute backgroundColor = attr1 "background-color" colorToString color : Color -> Attribute color = attr1 "color" colorToString media : a -> String media value = "media " ++ (toString value) -- TODO textShadow : TextShadow -> Attribute textShadow = attr1 "text-shadow" textShadowToString outline : Float -> Units -> OutlineStyle -> OpacityStyle -> Attribute outline = attr4 "outline" toString unitsToString (\str -> " " ++ outlineStyleToString str ++ " ") opacityStyleToString {- Types -} type Style class id = Style String (List Attribute) (List (Style class id)) type Attribute = Attribute String css : Style class id css = Style "" [] [] styleWithPrefix : String -> Style class id -> a -> Style class id styleWithPrefix prefix (Style selector attrs children) childSelector = children ++ [ Style (prefix ++ (toString childSelector)) [] [] ] |> Style selector attrs (|%|) : Style class id -> Tag -> Style class id (|%|) (Style selector attrs children) tag = children ++ [ Style (tagToString tag) [] [] ] |> Style selector attrs (|%|=) : Style class id -> List Tag -> Style class id (|%|=) (Style selector attrs children) tags = let childSelector = tags |> List.map tagToString |> String.join ", " in children ++ [ Style childSelector [] [] ] |> Style selector attrs (|@|) : Style class id -> a -> Style class id (|@|) = styleWithPrefix "@" (|::|) : Style class id -> a -> Style class id (|::|) = styleWithPrefix "::" (|>%|) : Style class id -> Tag -> Style class id (|>%|) (Style selector attrs children) tag = case splitStartLast children of ( _, Nothing ) -> children ++ [ Style (selector ++ " > " ++ tagToString tag) [] [] ] |> Style selector attrs ( start, Just (Style activeSelector _ _) ) -> children ++ [ Style (activeSelector ++ " > " ++ tagToString tag) [] [] ] |> Style selector attrs (|>%|=) : Style class id -> List Tag -> Style class id (|>%|=) (Style selector attrs children) tags = let selectorFromTag tag = case splitStartLast children of ( _, Nothing ) -> selector ++ " > " ++ tagToString tag ( start, Just (Style activeSelector _ _) ) -> activeSelector ++ " > " ++ tagToString tag childSelector = tags |> List.map selectorFromTag |> String.join ", " in children ++ [ Style childSelector [] [] ] |> Style selector attrs (|.|) : Style class id -> class -> Style class id (|.|) = styleWithPrefix "." (|#|) : Style class id -> id -> Style class id (|#|) = styleWithPrefix "#" (|>.|) : Style class id -> a -> Style class id (|>.|) = styleWithPrefix ">." (|!|) : Style class id -> Attribute -> Style class id (|!|) style (Attribute attrString) = transformActiveChild (addAttr (Attribute (attrString ++ " !important"))) style (|-|) : Style class id -> Attribute -> Style class id (|-|) style attr = transformActiveChild (addAttr attr) style addAttr : Attribute -> Style a b -> Style a b addAttr attr (Style selector attrs children) = Style selector (attrs ++ [ attr ]) children transformActiveChild : (Style a b -> Style a b) -> Style a b -> Style a b transformActiveChild transform (( Style selector attrs children ) as style) = case splitStartLast children of ( _, Nothing ) -> transform style ( inactiveChildren, Just activeChild ) -> Style selector attrs (inactiveChildren ++ [ transform activeChild ]) splitStartLast : List a -> (List a, Maybe a) splitStartLast list = case list of [] -> ( [], Nothing ) elem :: [] -> ( [], Just elem ) elem :: rest -> let ( start, last ) = splitStartLast rest in ( elem :: start, last ) ================================================ FILE: src/Http/Listeners.elm ================================================ module Http.Listeners (on) where {-| Module for event listener helpers @docs on -} import Native.Http {-| Wrapper for creating even listeners -} on : String -> target -> Signal input on = Native.Http.on ================================================ FILE: src/Http/Request.elm ================================================ module Http.Request ( Method(..) , Request, emptyReq , onCloseReq ) where {-| Stuff for dealing with requests # Handle Requests @docs Request, emptyReq @docs Method # Events @docs onCloseReq -} import Http.Listeners exposing (on) {-| Standard Http Methods, useful for routing -} type Method = GET | POST | PUT | DELETE | NOOP {-| Node.js native Request object [Node Docs](https://nodejs.org/api/http.html#http_http_incomingmessage) -} type alias Request = { url : String , method : Method } {-| `emptyReq` is a dummy Native Request object incase you need it, as the initial value of a `Signal.Mailbox` for example. -} emptyReq : Request emptyReq = { url = "" , method = NOOP } {-| "Close" events as a Signal for Request objects. [Node docs](https://nodejs.org/api/http.html#http_event_close_2) -} onCloseReq : Request -> Signal () onCloseReq = on "close" ================================================ FILE: src/Http/Response/Write.elm ================================================ module Http.Response.Write ( write, writeHead , writeHtml, writeJson , writeFile, writeElm , writeNode , end) where import Native.Http.Response.Write import Task exposing (Task, andThen) import VirtualDom exposing (Node) import Json.Encode as Json import Http.Response exposing (textHtml, applicationJson, Header, Response, StatusCode) {-| Write Headers to a Response [Node Docs](https://nodejs.org/api/http.html#http_response_writehead_statuscode_statusmessage_headers) -} writeHead : StatusCode -> Header -> Response -> Task x Response writeHead = Native.Http.Response.Write.writeHead {-| Write body to a Response [Node Docs](https://nodejs.org/api/http.html#http_response_write_chunk_encoding_callback) -} write : String -> Response -> Task x Response write = Native.Http.Response.Write.write {-| End a Response [Node Docs](https://nodejs.org/api/http.html#http_response_end_data_encoding_callback) -} end : Response -> Task x () end = Native.Http.Response.Write.end writeAs : Header -> String -> Response -> Task x () writeAs header html res = writeHead 200 header res `andThen` write html `andThen` end {-| Write out HTML to a Response. For example res `writeHtml` "

Howdy

" -} writeHtml : String -> Response -> Task x () writeHtml = writeAs textHtml {-| Write out JSON to a Response. For example res `writeJson` Json.object [ ("foo", Json.string "bar") , ("baz", Json.int 0) ] -} writeJson : Json.Value -> Response -> Task x () writeJson val res = writeAs applicationJson (Json.encode 0 val) res {-| write a file -} writeFile : String -> Response -> Task a () writeFile file res = writeHead 200 textHtml res `andThen` Native.Http.Response.Write.writeFile file `andThen` end {-| write elm! -} writeElm : String -> Response -> Task a () writeElm file res = writeHead 200 textHtml res `andThen` Native.Http.Response.Write.writeElm file `andThen` end writeNode : Node -> Response -> Task a () writeNode node res = writeHead 200 textHtml res `andThen` Native.Http.Response.Write.writeNode node `andThen` end ================================================ FILE: src/Http/Response.elm ================================================ module Http.Response ( Response, StatusCode, Header , emptyRes , textHtml, applicationJson , onCloseRes, onFinishRes ) where import Http.Listeners exposing (on) {-| An http header, such as content type -} type alias Header = (String, String) {-| StatusCode ie 200 or 404 -} type alias StatusCode = Int {-| Node.js native Response object [Node Docs](https://nodejs.org/api/http.html#http_class_http_serverresponse) -} type alias Response = { statusCode : StatusCode } {-| `emptyRes` is a dummy Native Response object incase you need it, as the initial value of a `Signal.Mailbox` for example. -} emptyRes : Response emptyRes = { statusCode = 418 } {-| Html Header {"Content-Type":"text/html"}-} textHtml : Header textHtml = ("Content-Type", "text/html") {-| Json Header {"Content-Type":"application/json"}-} applicationJson : Header applicationJson = ("Content-Type", "application/json") {-| "Close" events as a Signal for Response objects. [Node docs](https://nodejs.org/api/http.html#http_event_close_1) -} onCloseRes : Response -> Signal () onCloseRes = on "close" {-| "Finsh" events as a Signal for Response objects. [Node docs](https://nodejs.org/api/http.html#http_event_finish) -} onFinishRes : Response -> Signal () onFinishRes = on "finish" ================================================ FILE: src/Http/Server.elm ================================================ module Http.Server ( createServer, createServer', listen , Port, Server , onRequest, onClose) where {-| Simple bindings to Node.js's Http.Server # Init the server ## Instaniation @docs createServer, createServer' ## Actually listen @docs listen ## Types @docs Server, Port # Listen for events @docs onRequest, onClose -} import Task exposing (Task, succeed, andThen) import Signal exposing (Address, Mailbox, mailbox) import Json.Encode as Json import Http.Request exposing (Request) import Http.Response exposing (Response) import Http.Listeners exposing (on) import Native.Http {-| Port number for the server to listen -} type alias Port = Int {-| Node.js native Server object [Node Docs](https://nodejs.org/api/http.html#http_class_http_server) -} type Server = Server {-| "Request" events as a Signal. [Node docs](https://nodejs.org/api/http.html#http_event_request) -} onRequest : Server -> Signal (Request, Response) onRequest = on "request" {-| "Close" events as a Signal for Servers. [Node docs](https://nodejs.org/api/http.html#http_event_close) -} onClose : Server -> Signal () onClose = on "close" {-| Create a new Http Server, and send (Request, Response) to an Address. For example port serve : Task x Server port serve = createServer server.address [Node docs](https://nodejs.org/api/http.html#http_http_createserver_requestlistener) -} createServer : Address (Request, Response) -> Task x Server createServer = Native.Http.createServer {-| Create a Http Server and listen in one command! For example port serve : Task x Server port serve = createServer' server.address 8080 "Alive on 8080!" -} createServer' : Address (Request, Response) -> Port -> String -> Task x Server createServer' address port' text = createServer address `andThen` listen port' text {-| Command Server to listen on a specific port, and echo a message to the console when active. Task will not resolve until listening is successful. For example port listen : Task x Server port listen = listen 8080 "Listening on 8080" server [Node Docs](https://nodejs.org/api/http.html#http_server_listen_port_hostname_backlog_callback) -} listen : Port -> String -> Server -> Task x Server listen = Native.Http.listen ================================================ FILE: src/Native/Http/Response/Write.js ================================================ var COMPILED_DIR = '.comp'; var writeHead = function writeHead(Task) { return function (code, header, res) { var o = {}; return Task.asyncFunction(function (callback) { o[header._0] = header._1; res.writeHead(code, o); return callback(Task.succeed(res)); }); }; }; var write = function write(Task) { return function (message, res) { return Task.asyncFunction(function (callback) { res.write(message); return callback(Task.succeed(res)); }); }; }; var writeFile = function writeFile(fs, mime, Task){ return function (fileName, res) { return Task.asyncFunction(function (callback) { var file = __dirname + fileName; var type = mime.lookup(file); res.writeHead('Content-Type', type); fs.readFile(file, function (e, data) { res.end(data); return callback(Task.succeed(res)); }); }); }; }; var compile var writeElm = function writeElm(fs, mime, crypto, compiler, Task){ var compile = function(file, outFile, onClose){ // switch to the directory that the elm-app is served out of var dirIndex = file.lastIndexOf('/'); var dir = file.substr(0, dirIndex); process.chdir(dir); compiler.compile([file + '.elm'], { output: outFile, yes: true }).on('close', onClose); } return function (fileName, res) { var compiledFile = COMPILED_DIR + fileName + '.html'; // if the file is already compiled, just send it out if (fs.existsSync(compiledFile)) { return writeFile(fs, mime, Task)("/" + compiledFile, res); } return Task.asyncFunction(function (callback) { var file = __dirname + fileName; var outFile = __dirname + "/" + compiledFile; // when the file is compiled, attempt to send it out var onClose = function(exitCode) { var type = mime.lookup(file + '.html'); res.writeHead('Content-Type', type); fs.readFile(outFile, function (e, data) { res.end(data); return callback(Task.succeed(res)); }); }; compile(file, outFile, onClose); }); }; }; var writeNode = function writeNode(toHtml, Task){ return function(node, res) { return write(Task)(toHtml(node), res); }; }; var end = function end(Task, Tuple0) { return function (res) { return Task.asyncFunction(function (callback) { return (function () { res.end(); return callback(Task.succeed(Tuple0)); })(); }); }; }; var make = function make(localRuntime) { localRuntime.Native = localRuntime.Native || {}; localRuntime.Native.Http = localRuntime.Native.Http || {}; localRuntime.Native.Http.Response = localRuntime.Native.Http.Response || {}; localRuntime.Native.Http.Response.Write = localRuntime.Native.Http.Response.Write || {}; if (localRuntime.Native.Http.Response.Write.values) { return localRuntime.Native.Http.Response.Write.values; } var fs = require('fs'); var crypto = require('crypto'); var mime = require('mime'); var compiler = require('node-elm-compiler'); var toHtml = require('vdom-to-html'); var Task = Elm.Native.Task.make(localRuntime); var Utils = Elm.Native.Utils.make(localRuntime); var Tuple0 = Utils['Tuple0']; return { 'writeHead': F3(writeHead(Task)), 'writeFile': F2(writeFile(fs, mime, Task)), 'writeElm': F2(writeElm(fs, mime, crypto, compiler, Task)), 'writeNode': F2(writeNode(toHtml, Task)), 'write': F2(write(Task)), 'toHtml': toHtml, 'end': end(Task, Tuple0) }; }; Elm.Native = Elm.Native || {}; Elm.Native.Http = Elm.Native.Http || {}; Elm.Native.Http.Response = Elm.Native.Http.Response || {}; Elm.Native.Http.Response.Write = Elm.Native.Http.Response.Write || {}; Elm.Native.Http.Response.Write.make = make; if (typeof window === "undefined") { window = global; } ================================================ FILE: src/Native/Http.js ================================================ var COMPILED_DIR = '.comp'; // take a name as a string, return an elm object of the type // the name given var wrap_with_type = function(item){ return { ctor: item }; }; // make the directory for compiled Elm code var make_compile_dir = function(fs, dir){ if (typeof dir === "undefined"){ dir = COMPILED_DIR; } if (!fs.existsSync(dir)){ fs.mkdirSync(dir); } }; var createServer = function createServer(fs, http, Tuple2, Task) { return function (address) { make_compile_dir(fs, __dirname + "/" + COMPILED_DIR); var send = address._0; var server = http.createServer(function (request, response) { request.method = wrap_with_type(request.method); return Task.perform(send(Tuple2(request, response))); }); return Task.asyncFunction(function (callback) { return callback(Task.succeed(server)); }); }; }; var listen = function listen(Task) { return function (port, echo, server) { return Task.asyncFunction(function (callback) { return server.listen(port, function () { console.log(echo); return callback(Task.succeed(server)); }); }); }; }; var on = function on(Signal) { return function (eventName, x) { return x.on(eventName, function (request, response) { if (typeof(request) == 'undefined') { return Signal.input(eventName, Tuple0); } return Signal.input(eventName, Tuple(request, response)); }); }; }; var make = function make(localRuntime) { localRuntime.Native = localRuntime.Native || {}; localRuntime.Native.Http = localRuntime.Native.Http || {}; if (localRuntime.Native.Http.values) { return localRuntime.Native.Http.values; } var http = require('http'); var fs = require('fs'); var mime = require('mime'); var Task = Elm.Native.Task.make(localRuntime); var Utils = Elm.Native.Utils.make(localRuntime); var Signal = Elm.Native.Signal.make(localRuntime); var Tuple0 = Utils['Tuple0']; var Tuple2 = Utils['Tuple2']; return { 'createServer': createServer(fs, http, Tuple2, Task), 'listen': F3(listen(Task)), 'on': F2(on(Signal, Tuple0)) }; }; Elm.Native.Http = {}; Elm.Native.Http.make = make; if (typeof window === "undefined") { window = global; }