gistfile1.hs

{-# LANGUAGE OverloadedStrings, FlexibleContexts, RankNTypes, KindSignatures #-}
module Main 
  where

import Prelude hiding (FilePath)

import Data.ByteString as S
import Data.ByteString.Lazy as SL
import Data.ByteString.Lazy.Char8 as SL8

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

import Data.Time.Clock

import Control.Concurrent.STM
import Control.Exception (assert)
import Control.Monad.Reader
import Control.Monad.IO.Class

import Control.Applicative

import Data.Conduit
import qualified Data.Conduit.List   as CL
import qualified Data.Conduit.Binary as CB
import Data.Conduit.Network
import Data.HashMap.Lazy()
import Data.HashMap.Lazy as M


import Filesystem                 as F
import Filesystem.Path            as F
import Filesystem.Path.CurrentOS  as F

import Network.Sendfile()

type User = Text

-- | Information about file that will be processed
data FileServEntry = FileServEntry 
                      { fseUser :: User             -- ^ user 
                      , fseFile :: FilePath         -- ^ name of the file (relative)
                      , fseAccessTime :: UTCTime    -- ^ time of the last access
                      }

data FileServEnv = FileServEnv (TVar (HashMap SL8.ByteString FileServEntry))
                               (TVar (HashMap SL8.ByteString FileServEntry))

vmFsApplication (FileServEnv upload download) ad = appSource ad $$ sink 
  where
      cMap = M.fromList 
                [ (SL8.pack "upload", cmdUpload)
                , (SL8.pack "download", cmdDownload)
                ]
      sink = do
        takeLine >>= \c -> case M.lookup c cMap of
                             Just run -> run
                             Nothing -> closeEarly "no such command"
      cmdUpload = do
        ticket <- takeLine
        liftIO $ print ticket
        mfn <- liftIO . atomically $ fmap (M.lookup ticket) (readTVar upload)
        case mfn of
          Nothing -> closeEarly "no such command"
          Just (FileServEntry user file _) -> do
            let fullPath = "." </> F.fromText user </> file
            CL.mapM (\x -> liftIO (updateTime ticket) >> return x) =$ CB.sinkFile (F.encodeString fullPath)
            liftIO $ atomically $ readTVar upload >>= (writeTVar upload) . (M.delete ticket)
      cmdDownload = do
        token <- takeLine
        mfn <- liftIO . atomically $ fmap (M.lookup token) (readTVar download)
        case mfn of
          Nothing -> closeEarly "no such token"
          Just (FileServEntry user file _) -> do
            let fullPath = "." </> F.fromText user </> file
            CB.sourceFile (F.encodeString fullPath) $$ injectLeftovers (appSink ad)
      updateTime token = do
        nt <- fmap (addUTCTime 1800) getCurrentTime
        atomically $ do
          t <- readTVar upload
          writeTVar upload (M.adjust (\e -> e{fseAccessTime = nt}) token t)
        return ()
      closeEarly message = do
        liftIO $ Prelude.putStrLn $ "closing connection:" ++ message
        return ()

registerFileUpload user file = do
  FileServEnv upload _download <- ask
  let token = SL.fromChunks [T.encodeUtf8 user,F.encode file]
  liftIO $ do 
    tm <- fmap prolong getCurrentTime
    atomically $ readTVar upload >>= (writeTVar upload) . (M.insert token (FileServEntry user file tm))
  return token 

registerFileDownload :: (MonadReader FileServEnv m, MonadIO m) => User -> FilePath -> m SL.ByteString
registerFileDownload user file = do
  FileServEnv _upload download <- ask
  let token = SL.fromChunks [T.encodeUtf8 user, "-", F.encode file]
  liftIO $ do
    tm <- fmap prolong getCurrentTime
    atomically $ readTVar download >>= (writeTVar download) . (M.insert token (FileServEntry user file tm))
  return token

listFiles :: (MonadIO m) => Text -> m [(Text, Integer)] -- TODO: use either filepath or text (check API)
listFiles userName = do
  let path = "." 
  liftIO $ listDirectory path >>= mapM (\f -> getSize f >>= \s -> return (unsafeText f,s)) -- TODO make smth with unsafe


-- | Cleans expired tokens
tokenCleaner = undefined


-- TODO hide
unsafeText :: FilePath -> Text
unsafeText = either id id . toText

-- TODO hide
prolong :: UTCTime -> UTCTime
prolong = addUTCTime 1800

-- TODO: move to utils
takeLine :: forall o u (m :: * -> *).
             Monad m =>
               Pipe S.ByteString S.ByteString o u m SL8.ByteString
takeLine = 
    go id
    where 
      go front = await >>= maybe (return $ SL.fromChunks $ front []) go'
        where
          go' bs = case S.uncons y of
                     Just (_,y') -> assert (not $ S.null y') $ leftover y' >> return (SL.fromChunks $ front [x])
                     Nothing -> go (front . (x:))
              where 
                (x, y) = S.breakByte 10 bs 

main = do
    fileServConfig <- FileServEnv <$> atomically (newTVar M.empty) 
                                  <*> atomically (newTVar M.empty)
    runResourceT $ runTCPServer settings (vmFsApplication fileServConfig)
    return ()
  where
    settings = serverSettings 7890 HostAny  

FileServ.hs:50:68:
Occurs check: cannot construct the infinite type:
m0 = Pipe S.ByteString S.ByteString Data.Void.Void () m0
Expected type: Sink
S.ByteString
(Pipe S.ByteString S.ByteString Data.Void.Void () m0)
()
Actual type: Pipe
S.ByteString S.ByteString Data.Void.Void () m0 ()
In the second argument of ($$)', namelysink'
In the expression: appSource ad $$ sink