For fun I decided to write a 'real' Haskell program. The intention of the program is that it listens on a socket on a given port for input. The client can send some raw text on it and the server generates a paste for it.
As an example:
Client
dino :: ~ % echo "Schoolbus" | nc call-cc.be 9999
http://call-cc.be/files/3DFJC
Server
./carte -d /var/www/ssl/files -p 9999 -h call-cc.be/files
In the above example, the url the client got back will point to a raw textfile that contains "Schoolbus".
In particular, I think there might be a more decent way to thread the configuration through the entire program. Now I use a StateT monad, but it is only useful for the loop and randId function. Maybe the State transformer is a bit of overkill?
And a second thing I have been wondering about. Should I worry about exploits? Should I sanitize the input or some sort? I would like to actually deploy this on my server so I would like to be safe.
And finally, I am unsure how I can exploit the typesystem more thorougly for my arguments. For example, now all my arguments have the same type, namely Arguments. The problem is that, in my code I could write code like (h (Port 1234)), which typechecks but is not correct and will throw a runtime error. I think I might have cut some corners here.
module Main where
import Base36
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.Char
import Data.List
import Data.Time.Clock.POSIX
import Network
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.IO
import System.Random
import Text.Printf
data Data = D { rnd :: StdGen, opts :: Opts }
main :: IO ()
main = do t <- currentTimeSeconds
opts <- liftM buildOpts getArgs
putStrLn $ printf "Config: %s" (show opts)
withSocketsDo $
do s <- listenOn (PortNumber $ fromInteger . p . port $ opts)
evalStateT (loop s) (D (mkStdGen t) opts)
return ()
----------------------
-- Argument Parsing --
----------------------
data Opts = Opts { port :: Arguments, host :: Arguments, files :: Arguments }
deriving (Show, Eq)
data Arguments
= Port { p :: Integer }
| HostName { h :: String }
| FileDir { dir :: String }
deriving (Show, Eq)
parseArg as arg constr process deflt =
let args = take 2 . dropWhile (/= arg) $ as
in
case args of
[arg, opts] -> constr (process opts)
_ -> constr deflt
parsePort as = parseArg as "-p" Port read 5001
parseHost as = parseArg as "-h" HostName id "localhost"
parseFileDir as = parseArg as "-d" FileDir id "."
buildOpts args = Opts { port = parsePort args,
host = parseHost args,
files = parseFileDir args }
buildFileUrl url id = if last url == '/'
then url ++ id
else url ++ "/" ++ id
---------------------
-- Socket handling --
---------------------
loop :: Socket -> StateT Data IO ()
loop s =
do (h,_,_) <- lift $ accept s
id <- randId
conf <- liftM opts get
lift . forkIO $ process h id conf
loop s
process :: Handle -> String -> Opts -> IO ()
process hdl id opts = do d <- eatData hdl []
let filepath = combine (dir . files $ opts) id
saveToDisk filepath d
hPutStrLn hdl $ buildFileUrl (h . host $ opts) id
hFlush hdl
hClose hdl
eatData :: Handle -> [String] -> IO [String]
eatData handle ls =
do l <- hGetLine handle
end <- hIsEOF handle
if end
then return $ l:ls
else eatData handle $ l:ls
saveToDisk :: FilePath -> [String] -> IO ()
saveToDisk fp ls = do path <- canonicalizePath fp
putStrLn $ printf "Writing file to %s" path
writeFile path (intercalate "\n" ls)
--------------------------
-- Random ID generation --
--------------------------
randId :: StateT Data IO String
randId = do d <- get
let (str, gen') = random (rnd d)
put (d { rnd = gen' })
return $ base36 str
currentTimeSeconds :: IO Int
currentTimeSeconds = round `fmap` getPOSIXTime
