Skip to content
Browse files

Initial commit

  • Loading branch information...
0 parents commit ac03264d466aa25ceb440ac43b4e1b34668bea1d @bergmark bergmark committed Jan 2, 2013
Showing with 212 additions and 0 deletions.
  1. +6 −0 .gitignore
  2. +30 −0 LICENSE
  3. +23 −0 fay-uri.cabal
  4. +130 −0 src/Language/Fay/Uri.hs
  5. +23 −0 test.hs
6 .gitignore
@@ -0,0 +1,6 @@
+*.hi
+*.o
+cabal-dev
+*.html
+*.js
+dist
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Adam Bergmark
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Chris Done nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
23 fay-uri.cabal
@@ -0,0 +1,23 @@
+name: fay-uri
+version: 0.1.0.0
+synopsis: Persistent FFI bindings for using jsUri in Fay
+homepage: https://github.com/faylang/fay-uri
+bug-reports: https://github.com/faylang/fay-uri/issues
+license: BSD3
+license-file: LICENSE
+author: Adam Bergmark
+maintainer: adam@edea.se
+copyright: 2013 Adam Bergmark
+category: Web
+build-type: Simple
+cabal-version: >=1.8
+
+data-files:
+ src/Language/Fay/Uri.hs
+
+library
+ hs-source-dirs: src
+ exposed-modules: Language.Fay.Uri
+ Paths_fay_uri
+ build-depends: base,
+ fay
130 src/Language/Fay/Uri.hs
@@ -0,0 +1,130 @@
+{-# Language EmptyDataDecls #-}
+{-# Language NoImplicitPrelude #-}
+
+module Language.Fay.Uri where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
+-- Creation and conversion
+
+-- Choose to make Uri an opaque data type. If the accessors on the
+-- jsUri objects were properties and not functions we could have
+-- defined Uri as a record instead.
+data Uri
+instance Foreign Uri
+
+currentUri :: Fay String
+currentUri = ffi "window.location.href"
+
+-- This assumes that Uri is defined globally, which it is by default.
+newUri :: String -> Uri
+newUri = ffi "new window.Uri(%1)"
+
+toString :: Uri -> String
+toString = ffi "%1.toString()"
+
+-- Getters
+
+protocol :: Uri -> String
+protocol = ffi "%1.protocol()"
+
+userInfo :: Uri -> String
+userInfo = ffi "%1.userInfo()"
+
+host :: Uri -> String
+host = ffi "%1.host()"
+
+port :: Uri -> String
+port = ffi "%1.port()"
+
+path :: Uri -> String
+path = ffi "%1.path()"
+
+query :: Uri -> String
+query = ffi "%1.query()"
+
+anchor :: Uri -> String
+anchor = ffi "%1.anchor()"
+
+-- Other getters
+
+queryParamValue :: String -> Uri -> String
+queryParamValue = ffi "%2.getQueryParamValue(%1)"
+
+queryParamValues :: String -> Uri -> [String]
+queryParamValues = ffi "%2.getQueryParamValues(%1)"
+
+-- Setters
+
+-- We could use Language.FFI.Nullable here to combine the with* and remove* functions
+-- but usage would be more verbose that way.
+-- `Nullable a` is converted to `a` through the FFI and `Null` is converted to null.
+
+-- JsUri has clone() conveniently defined so we use it to get
+-- persistence, otherwise our types would be `-> Fay Uri` which is of
+-- course worse.
+
+withProtocol :: String -> Uri -> Uri
+withProtocol = ffi "%2.clone().setProtocol(%1)"
+
+withUserInfo :: String -> Uri -> Uri
+withUserInfo = ffi "%2.clone().setUserInfo(%1)"
+
+withHost :: String -> Uri -> Uri
+withHost = ffi "%2.clone().setHost(%1)"
+
+withPort :: String -> Uri -> Uri
+withPort = ffi "%2.clone().setPort(%1)"
+
+withPath :: String -> Uri -> Uri
+withPath = ffi "%2.clone().setPath(%1)"
+
+withQuery :: String -> Uri -> Uri
+withQuery = ffi "%2.clone().setQuery(%1)"
+
+withAnchor :: String -> Uri -> Uri
+withAnchor = ffi "%2.clone().setAnchor(%1)"
+
+-- Removals
+
+removeProtocol :: Uri -> Uri
+removeProtocol = ffi "%1.clone().setProtocol(null)"
+
+removeUserInfo :: Uri -> Uri
+removeUserInfo = ffi "%1.clone().setUserInfo(null)"
+
+removeHost :: Uri -> Uri
+removeHost = ffi "%1.clone().setHost(null)"
+
+removePort :: Uri -> Uri
+removePort = ffi "%1.clone().setPort(null)"
+
+removePath :: Uri -> Uri
+removePath = ffi "%1.clone().setPath(null)"
+
+removeQuery :: Uri -> Uri
+removeQuery = ffi "%1.clone().setQuery(null)"
+
+removeAnchor :: Uri -> Uri
+removeAnchor = ffi "%1.clone().setAnchor(null)"
+
+
+-- Other setters
+
+addQueryParam :: String -> String -> Uri -> Uri
+addQueryParam = ffi "%3.clone().addQueryParam(%1,%2)"
+
+replaceQueryParam :: String -> String -> Uri -> Uri
+replaceQueryParam = ffi "%3.clone().replaceQueryParam(%1,%2)"
+
+-- The order of the arguments differ from the jsUri api, it is now
+-- key -> oldValue -> newValue -> Uri -> Uri
+replaceQueryParamValue :: String -> String -> String -> Uri -> Uri
+replaceQueryParamValue = ffi "%4.clone().replaceQueryParam(%1, %3, %2)"
+
+deleteQueryParam :: String -> Uri -> Uri
+deleteQueryParam = ffi "%2.clone().deleteQueryParam(%1)"
+
+deleteQueryParamValue :: String -> String -> Uri -> Uri
+deleteQueryParamValue = ffi "%3.clone().deleteQueryParam(%1,%2)"
23 test.hs
@@ -0,0 +1,23 @@
+module Main where
+
+import Language.Fay.Uri
+import Language.Fay.Prelude
+
+main :: Fay ()
+main = do
+ let uri = newUri "http://user:pass@www.example.com:80/ppp?a=b#c"
+ putStrLn . toString . newUri =<< currentUri
+ print uri
+ putStrLn "--"
+ mapM_ (putStrLn . ($ uri))
+ [toString, protocol, host, port, path, query, anchor]
+ putStrLn "--"
+ mapM_ (putStrLn . toString . ($ uri))
+ [withProtocol "https", withUserInfo "foo:bar", withHost "example.net", withPort "90", withPath "path", withQuery "e=f", withAnchor "g"]
+ putStrLn "--"
+ mapM_ (putStrLn . toString . ($ uri))
+ [removeProtocol, removeUserInfo, removeHost, removePort, removePath, removeQuery, removeAnchor]
+ putStrLn "--"
+ mapM_ (putStrLn . toString . ($ uri))
+ [addQueryParam "c" "d", replaceQueryParam "a" "e", replaceQueryParamValue "a" "b" "f"
+ ,deleteQueryParam "a", deleteQueryParamValue "a" "b"]

0 comments on commit ac03264

Please sign in to comment.
Something went wrong with that request. Please try again.