Rfc2397 wip

Author: functora

ghcjs/miso-functora/test/Functora/Miso/TypesSpec.hs

@@ -8,6 +8,7 @@ import qualified Optics.Setter as Ops
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck.Instances ()
+import qualified Text.URI as URI
 
 data Expr
   = Lit Int

pub/functora/functora.cabal

@@ -176,9 +176,11 @@ common pkg-web
   hs-source-dirs: src/web
   build-depends:
     , base
+    , base64-bytestring
     , http-types
     , modern-uri
     , network-uri
+    , uri-encode
 
   if impl(ghcjs)
     build-depends: ghcjs-base
@@ -311,6 +313,7 @@ library web
   exposed:         True
   visibility:      public
   exposed-modules:
+    Functora.Rfc2397
     Functora.Web
     Functora.WebOrphan
 
@@ -407,6 +410,7 @@ test-suite functora-test
     Functora.Tags.TestFgpt
     Functora.Tags.TestSing
     Functora.TagsSpec
+    Functora.WebSpec
 
   if flag(ghcid)
     import:
@@ -430,6 +434,7 @@ test-suite functora-test
       Functora.Qr
       Functora.QrOrphan
       Functora.Rates
+      Functora.Rfc2397
       Functora.Soplate
       Functora.Sql
       Functora.SqlOrphan

pub/functora/src/test/Functora/CfgSpec.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 module Functora.CfgSpec (spec) where
 
 import Functora.Cfg

pub/functora/src/test/Functora/Elm2MisoSpec.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 module Functora.Elm2MisoSpec (spec) where
 
 import Data.String.QQ

pub/functora/src/test/Functora/WebSpec.hs

@@ -0,0 +1,16 @@
+module Functora.WebSpec (spec) where
+
+import Functora.Prelude
+import qualified Functora.Rfc2397 as Rfc2397
+import Test.Hspec
+import Test.QuickCheck.Instances ()
+
+dot :: String
+dot =
+  "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAAHElEQVQI12P4//8/w38GIAXDIBKE0DHxgljNBAAO9TXL0Y4OHwAAAABJRU5ErkJggg=="
+
+spec :: Spec
+spec = do
+  it "encode/decode" $
+    fmap (uncurry Rfc2397.encode) (Rfc2397.decode dot)
+      `shouldBe` Just dot

pub/functora/src/web/Functora/Rfc2397.hs

@@ -0,0 +1,71 @@
+module Functora.Rfc2397
+  ( encode,
+    decode,
+  )
+where
+
+import qualified Data.ByteString.Base64 as B64
+import Functora.Prelude
+import qualified Network.URI.Encode as UE
+import qualified Prelude
+
+data ENC = BASE64 | URL
+  deriving stock (Eq)
+
+encode :: String -> ByteString -> String
+encode mime bs =
+  "data:"
+    <> mime
+    <> ";base64,"
+    <> either impureThrow id (decodeUtf8Strict $ B64.encode bs)
+
+decode :: String -> Maybe (String, ByteString)
+decode url =
+  let (scheme, rest) = break (== ':') url
+   in case rest of
+        ':' : contents | scheme == "data" -> decodeContents contents
+        _ -> Nothing
+
+decodeContents :: String -> Maybe (String, ByteString)
+decodeContents xs =
+  let (prefix, restdata) = break (== ',') xs
+   in case restdata of
+        ',' : thedata -> decodePrefix prefix thedata
+        _ -> Nothing
+
+decodePrefix :: String -> String -> Maybe (String, ByteString)
+decodePrefix prefix thedata =
+  let fragments = breakList (== ';') prefix
+      enc = case reverse fragments of
+        ("base64" : _) -> BASE64
+        _ -> URL
+      mediapart
+        | enc == BASE64 = Prelude.init fragments
+        | otherwise = fragments
+   in case mediapart of
+        (xs : _) ->
+          case break (== '/') xs of
+            (_, []) -> decodeData ("text/plain" : mediapart) enc thedata
+            _ -> decodeData mediapart enc thedata
+        _ -> decodeData ["text/plain", "charset=US-ASCII"] enc thedata
+
+decodeData :: [String] -> ENC -> String -> Maybe (String, ByteString)
+decodeData mediatype enc thedata =
+  Just
+    ( unparse mediatype,
+      case enc of
+        URL -> encodeUtf8 $ UE.decode thedata
+        BASE64 -> either Prelude.error id . B64.decode $ encodeUtf8 thedata
+    )
+
+breakList :: (x -> Bool) -> [x] -> [[x]]
+breakList p xs =
+  let (pre, post) = break p xs
+   in case post of
+        [] -> [pre]
+        _ : ys -> pre : breakList p ys
+
+unparse :: [String] -> String
+unparse [] = ""
+unparse [xs] = xs
+unparse (xs : xss) = xs ++ ';' : unparse xss