Rfc2397 simple tests

Author: functora

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

@@ -5,12 +5,15 @@ import qualified Functora.Rfc2397 as Rfc2397
 import Test.Hspec
 import Test.QuickCheck.Instances ()
 
-dot :: String
-dot =
-  "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAAHElEQVQI12P4//8/w38GIAXDIBKE0DHxgljNBAAO9TXL0Y4OHwAAAABJRU5ErkJggg=="
+smaples :: [String]
+smaples =
+  [ "data:text/vnd-example+xyz;foo=bar;base64,R0lGODdh",
+    "data:text/plain;charset=UTF-8;page=21,the%20data:1234,5678",
+    "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAAHElEQVQI12P4//8/w38GIAXDIBKE0DHxgljNBAAO9TXL0Y4OHwAAAABJRU5ErkJggg==",
+    "data:image/jpeg;base64,/9j/4AAQSkZJRgABAQEAYABgAAD/2wBDADIiJSwlHzIsKSw4NTI7S31RS0VFS5ltc1p9tZ++u7Kfr6zI4f/zyNT/16yv+v/9////////wfD/////////////2wBDATU4OEtCS5NRUZP/zq/O////////////////////////////////////////////////////////////////////wAARCAAYAEADAREAAhEBAxEB/8QAGQAAAgMBAAAAAAAAAAAAAAAAAQMAAgQF/8QAJRABAAIBBAEEAgMAAAAAAAAAAQIRAAMSITEEEyJBgTORUWFx/8QAFAEBAAAAAAAAAAAAAAAAAAAAAP/EABQRAQAAAAAAAAAAAAAAAAAAAAD/2gAMAwEAAhEDEQA/AOgM52xQDrjvAV5Xv0vfKUALlTQfeBm0HThMNHXkL0Lw/swN5qgA8yT4MCS1OEOJV8mBz9Z05yfW8iSx7p4j+jA1aD6Wj7ZMzstsfvAas4UyRHvjrAkC9KhpLMClQntlqFc2X1gUj4viwVObKrddH9YDoHvuujAEuNV+bLwFS8XxdSr+Cq3Vf+4F5RgQl6ZR2p1eAzU/HX80YBYyJLCuexwJCO2O1bwCRidAfWBSctswbI12GAJT3yiwFR7+MBjGK2g/WAJR3FdF84E2rK5VR0YH/9k="
+  ]
 
 spec :: Spec
 spec = do
-  it "encode/decode" $
-    fmap (uncurry Rfc2397.encode) (Rfc2397.decode dot)
-      `shouldBe` Just dot
+  it "encode/decode" . forM_ smaples $ \sample ->
+    fmap Rfc2397.encode (Rfc2397.decode sample) `shouldBe` Just sample

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

@@ -1,46 +1,68 @@
 module Functora.Rfc2397
-  ( encode,
+  ( Media (..),
+    Encoding (..),
+    encode,
     decode,
   )
 where
 
 import qualified Data.ByteString.Base64 as B64
 import Functora.Prelude
+import qualified Network.URI as URI
 import qualified Network.URI.Encode as UE
 import qualified Prelude
 
-data ENC = BASE64 | URL
-  deriving stock (Eq)
+data Media = Media
+  { mediaMime :: String,
+    mediaBytes :: ByteString,
+    mediaEncoding :: Encoding
+  }
+  deriving stock (Eq, Ord, Show, Data, Generic)
 
-encode :: String -> ByteString -> String
-encode mime bs =
+data Encoding = B64Encoding | UrlEncoding
+  deriving stock (Eq, Ord, Show, Read, Data, Generic, Bounded, Enum)
+
+encode :: Media -> String
+encode Media {mediaMime = mime, mediaBytes = bs, mediaEncoding = enc} =
   "data:"
     <> mime
-    <> ";base64,"
-    <> either impureThrow id (decodeUtf8Strict $ B64.encode bs)
+    <> ( case enc of
+          B64Encoding -> ";base64"
+          UrlEncoding -> mempty
+       )
+    <> ","
+    <> ( case enc of
+          B64Encoding ->
+            either impureThrow id
+              . decodeUtf8Strict
+              $ B64.encode bs
+          UrlEncoding ->
+            either impureThrow (UE.encodeWith URI.isAllowedInURI)
+              $ decodeUtf8Strict bs
+       )
 
-decode :: String -> Maybe (String, ByteString)
+decode :: String -> Maybe Media
 decode url =
   let (scheme, rest) = break (== ':') url
    in case rest of
         ':' : contents | scheme == "data" -> decodeContents contents
         _ -> Nothing
 
-decodeContents :: String -> Maybe (String, ByteString)
+decodeContents :: String -> Maybe Media
 decodeContents xs =
   let (prefix, restdata) = break (== ',') xs
    in case restdata of
         ',' : thedata -> decodePrefix prefix thedata
         _ -> Nothing
 
-decodePrefix :: String -> String -> Maybe (String, ByteString)
+decodePrefix :: String -> String -> Maybe Media
 decodePrefix prefix thedata =
   let fragments = breakList (== ';') prefix
       enc = case reverse fragments of
-        ("base64" : _) -> BASE64
-        _ -> URL
+        ("base64" : _) -> B64Encoding
+        _ -> UrlEncoding
       mediapart
-        | enc == BASE64 = Prelude.init fragments
+        | enc == B64Encoding = Prelude.init fragments
         | otherwise = fragments
    in case mediapart of
         (xs : _) ->
@@ -49,14 +71,20 @@ decodePrefix prefix 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
-    )
+decodeData :: [String] -> Encoding -> String -> Maybe Media
+decodeData mediatype enc thedata = do
+  bs <-
+    case enc of
+      UrlEncoding ->
+        pure . encodeUtf8 $ UE.decode thedata
+      B64Encoding ->
+        either (const Nothing) Just . B64.decode $ encodeUtf8 thedata
+  pure
+    Media
+      { mediaMime = unparse mediatype,
+        mediaBytes = bs,
+        mediaEncoding = enc
+      }
 
 breakList :: (x -> Bool) -> [x] -> [[x]]
 breakList p xs =