1 files changed, 36 insertions, 45 deletions
diff --git a/src/Main.hs b/src/Main.hs
index c8290db..feb199b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,65 +1,56 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
+    TypeFamilies, ViewPatterns, LambdaCase #-}
 
 module Main (main) where
 
-import Control.Concurrent.STM.TChan
-import Control.Monad (forever)
-import Data.Aeson
-import Data.ByteString (ByteString, toStrict)
-import GHC.Conc
-import Network.HTTP.Simple (Response, httpJSON, getResponseBody)
-import System.AtomicWrite.Writer.LazyByteString (atomicWriteFile)
 import Yesod
+import Network.Wai.Handler.Warp
+import Data.Function ((&))
 
 import qualified Data.ByteString as BS
 
 import Bangs
+import BangState
 
 data Search = Search {
-    ownBangs :: TVar Bangs,
-    ddgBangs :: TVar Bangs,
-    serializedBangs :: TVar ByteString,
-    syncFileNotifications :: TChan ()
+    bangState :: BangState
 }
 
-reserialize :: Search -> STM ()
-reserialize s = do
-    own <- readTVar $ ownBangs s
-    ddg <- readTVar $ ddgBangs s
-    writeTVar (serializedBangs s) $ toStrict $ encode $ own <> ddg -- left biased union
-    writeTChan (syncFileNotifications s) ()
+mkYesod "Search" [parseRoutes|
+/           HomeR GET
+/bangs.json BangsR GET
+/submitBang SubmitR POST
+|]
 
--- second argument: readable tchan, duped from the tchan in 'Search'
-fileSyncThread :: Search -> TChan () -> IO a
-fileSyncThread s rc = forever $ do
-    nextBangs <- atomically $ do
-        readTChan rc
-        readTVar (ownBangs s)
-    atomicWriteFile "bangs.json" $ encode nextBangs
+instance Yesod Search where
+    makeSessionBackend _ = return Nothing
 
-spawnFileSyncThread :: Search -> IO ()
-spawnFileSyncThread s = do
-    readableChan <- atomically $ dupTChan (syncFileNotifications s)
-    forkIO $ fileSyncThread s readableChan
-    return ()
+getHomeR :: Handler String
+getHomeR = return "TODO"
 
-loadOwnBangs :: IO Bangs
-loadOwnBangs = eitherDecodeFileStrict "bangs.json" >>= \case
-    Left e -> error e
-    Right b -> return b
+getBangsR :: Handler TypedContent
+getBangsR = do
+    bangsAccessor <- lookupHeader "accept-encoding" >>= \case
+        Just ae | "br" `BS.isInfixOf` ae -> do
+            addHeader "transfer-encoding" "br"
+            return getBangsBrotli
+        _ -> do
+            return getBangsJSON
+
+    bs <- liftIO . bangsAccessor . bangState =<< getYesod
+    return $ TypedContent typeJson $ toContent bs
+
+postSubmitR :: Handler String
+postSubmitR = return "TODO"
 
 main :: IO ()
 main = do
-    ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response DDGBangs)
     s <- Search
-        <$> (loadOwnBangs >>= newTVarIO)
-        <*> newTVarIO (toBangs $ getResponseBody ans)
-        <*> newTVarIO BS.empty
-        <*> newBroadcastTChanIO
-
-    spawnFileSyncThread s
-    atomically $ reserialize s
+        <$> initBangState
 
-    print =<< readTVarIO (serializedBangs s)
-    _ <- getLine
-    return ()
+    sApp <- toWaiApp s -- includes middlewares
+    let settings = defaultSettings
+            -- currently, "*" seems to bind only to ipv4 while "*6" binds to both
+            & setHost "*6"
+            & setPort 20546
+    runSettings settings sApp