{-# LANGUAGE OverloadedStrings #-}
import Network.HTTP
import Control.Exception
import Network.Wai
import Network.Wai.Handler.Warp
import System.Environment
import System.IO
import System.Directory
import Control.Monad.IO.Class
import Data.Map(Map)
import qualified Data.Map as Map
import qualified  Data.ByteString.Char8 as BS
import qualified  Data.ByteString.Lazy.Char8 as BL
import Control.Concurrent.MVar
import Blaze.ByteString.Builder (fromByteString)
import Network.HTTP.Types (status200,status404)
import Control.Applicative
import Data.IORef
import Data.Maybe
import Network.Browser

main :: IO ()
main = do
  port <- getEnv "PORT"
  cachedir <- BS.pack <$> getEnv "cachedir"
  pending <- newMVar Map.empty
  memCache <- newIORef []
  run (read port) $ \req -> do
    let (domain,path)= BS.breakSubstring "/favicon.ico" (rawPathInfo req)
    -- liftIO $ print (domain, path, rawPathInfo req)
    if path == "/favicon.ico"
      then do
        let dom = BS.tail domain

        let filename = BS.concat [cachedir,domain]
        f <- liftIO (proxy pending memCache dom (BS.unpack filename))
        return $ ResponseBuilder status200 [("Content-Disposition", "binary/data")] $ fromByteString f
      else return $ ResponseBuilder status404 [] $ fromByteString ""

proxy :: MVar (Map BS.ByteString (MVar ()) ) -> IORef ([(BS.ByteString, BS.ByteString)]) -> BS.ByteString -> String -> IO BS.ByteString
proxy pending memcache domain filename = do
  cached <- readIORef memcache
  case lookup domain cached of
    Just resp -> return resp
    Nothing -> do
      exists <- doesFileExist filename
      handle handler $ do
        m <- takeMVar pending
        maybe (fetch m memcache) (waitForRef m memcache) (Map.lookup domain m)

  where fetch m cache  = do
          p <- newEmptyMVar
          putMVar pending (Map.insert domain p m)
          (_, resp_raw) <- Network.Browser.browse $ do
                                  setAllowRedirects True
                                  request (getRequest $ BS.unpack $ BS.concat ["http://", domain, "/favicon.ico"])
          let resp =  rspBody resp_raw
          writeFile filename resp
          let strict = BS.pack resp
          atomicModifyIORef cache (\x -> ((domain,strict):x, ()))
          putMVar p ()
          modifyMVar_ pending (\m -> return $ Map.delete domain m)
          return strict

        waitForRef m cache ref = do
          putMVar pending m
          takeMVar ref
          putMVar ref ()
          readIORef cache >>= return  . fromJust . lookup domain

        handler :: SomeException -> IO BS.ByteString
        handler e = hPrint stderr e >> return "error"