Add HLS streaming API

4 files changed, 56 insertions, 1 deletions

diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-web/src/Fig/Web/DB.hs
index 9b1728c..0f600c6 100644
--- a/fig-web/src/Fig/Web/DB.hs
+++ b/fig-web/src/Fig/Web/DB.hs
@@ -96,3 +96,11 @@ rpush :: MonadIO m => DB -> ByteString -> ByteString -> m ()
 rpush (DB c) key val = liftIO $ Redis.runRedis c do
   _ <- Redis.rpush key [val]
   pure ()
+
+llen :: MonadIO m => DB -> ByteString -> m (Maybe Integer)
+llen (DB c) key = liftIO $ Redis.runRedis c do
+  hush <$> Redis.llen key
+
+lindex :: MonadIO m => DB -> ByteString -> Integer -> m (Maybe ByteString)
+lindex (DB c) key idx = liftIO $ Redis.runRedis c do
+  join . hush <$> Redis.lindex key idx
diff --git a/fig-web/src/Fig/Web/Module/HLS.hs b/fig-web/src/Fig/Web/Module/HLS.hs
new file mode 100644
index 0000000..306be06
--- /dev/null
+++ b/fig-web/src/Fig/Web/Module/HLS.hs
@@ -0,0 +1,41 @@
+module Fig.Web.Module.HLS
+  ( public
+  ) where
+
+import Fig.Prelude
+
+import Data.Functor ((<&>))
+
+import Fig.Web.Utils
+import Fig.Web.Types
+import qualified Fig.Web.DB as DB
+
+public :: PublicModule
+public a = do
+  onGet "/api/hls.m3u8" do
+    mseq :: Maybe Integer <- ((readMaybe . unpack . decodeUtf8)=<<) <$> DB.get a.db "hlssequence"
+    mlen <- DB.llen a.db "hlssamples"
+    case (mseq, mlen) of
+      (Just seq, Just len) -> do
+        let startingSeq = seq - (len - 1)
+        respondText $ mconcat
+          [ "#EXTM3U\n"
+          , "#EXT-X-VERSION: 4\n"
+          , "#EXT-X-TARGETDURATION:5\n"
+          , "#EXT-X-MEDIA-SEQUENCE:", tshow startingSeq, "\n"
+          , mconcat $ reverse [0,1..len] <&> \idx -> mconcat
+            [ "#EXTINF:3.0,\n"
+            , "http://localhost:8080/api/hls/", tshow idx, "/sample.aac\n"
+            ]
+          ]
+      _ -> do
+        status status404
+        respondText "no HLS stream"
+    pure ()
+  onGet "/api/hls/:num/sample.aac" do
+    num <- pathParam "num"
+    DB.lindex a.db "hlssamples" num >>= \case
+      Nothing -> do
+        status status404
+        respondText "sample not found"
+      Just val -> respondBytes val
diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs
index 1ff9962..dafe039 100644
--- a/fig-web/src/Fig/Web/Public.hs
+++ b/fig-web/src/Fig/Web/Public.hs
@@ -24,6 +24,7 @@ import qualified Fig.Web.Module.Model as Model
 import qualified Fig.Web.Module.Bells as Bells
 import qualified Fig.Web.Module.User as User
 import qualified Fig.Web.Module.Shader as Shader
+import qualified Fig.Web.Module.HLS as HLS
 
 allBusEvents :: PublicModuleArgs -> BusEventHandlers
 allBusEvents args = busEvents . mconcat $ fmap ($ args)
@@ -90,6 +91,7 @@ app args = do
     Bells.public args
     User.public args
     Shader.public args
+    HLS.public args
     websocket $ mconcat
       [ Gizmo.publicWebsockets args
       , Circle.publicWebsockets args
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index 521e781..72782d9 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -11,7 +11,7 @@ module Fig.Web.Utils
   , status
   , queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam
   , header
-  , respondText, respondJSON, respondHTMLText, respondHTML, redirect
+  , respondBytes, respondText, respondJSON, respondHTMLText, respondHTML, redirect
   , WebsocketHandler
   , websocket
   , BusEventHandler, BusEventHandlers
@@ -30,6 +30,7 @@ import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as Text.L
+import qualified Data.ByteString.Lazy as BS.L
 import qualified Data.Aeson as Aeson
 import qualified Data.Map.Strict as Map
 
@@ -144,6 +145,9 @@ header h = Sc.header (Text.L.fromStrict h) >>= \case
   Nothing -> pure Nothing
   Just t -> pure . Just $ Text.L.toStrict t
 
+respondBytes :: ByteString -> Sc.ActionM ()
+respondBytes = Sc.raw . BS.L.fromStrict
+
 respondText :: Text -> Sc.ActionM ()
 respondText = Sc.text . Text.L.fromStrict