2
\$\begingroup\$

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
\$\endgroup\$
0

2 Answers 2

2
\$\begingroup\$

Argument Parsing

As you noted, your options/arguments code is a little off-kilter. If you check out some argument parsing libraries on Hackage (search “argument” for a pretty good sample) the design space will probably serve as a good guide for how to structure your application configuration value, and help you from reinventing argument parsing all on your own!

I like optparse-applicative myself, which allows you to build a fully featured command line utility interface with just a few simple combinators. E.g., you get nicely formatted usage info basically for free!

Start by defining a configuration datatype with fields that have the actual values you're looking to capture.

data Configuration =
  Configuration
    { port  :: Int
    , url   :: String
    , files :: String
    } deriving (Show)

Next we'll define a Parser for Configuration values by building one out of Parsers for its component values. The applicative combinator pattern used here is a common style that you'll run into in many other places, notably including aeson when parsing JSON values.

import Options.Applicative

portParser :: Parser Int
portParser =
    option auto        -- an option which reads its argument with Read
      ( short 'p'      -- a short name i.e. "-p"
     <> long "port"    -- a long name i.e. "--port"
     <> metavar "PORT" -- a symbolic name in the help text
     <> value 5001     -- a default value
     <> help "The PORT on which to listen for connections" )

urlParser :: Parser String
urlParser =
    strOption
      ( short 'u'
     <> long "url"
     <> metavar "URL"
     <> value "localhost"
     <> help "The root url for building links to files" )

filesParser :: Parser String
filesParser =
    strOption
      ( short 'd'
     <> long "dir"
     <> metavar "DIRECTORY"
     <> value "."
     <> help "The DIRECTORY in which to store pastes" )

configuration :: Parser Configuration
configuration =
    Configuration
      <$> portParser
      <*> urlParser
      <*> filesParser

Then this parser can be used from the entry point of your program. A few extra annotations gets us a very robust, fully featured parser.

main :: IO ()
main = execParser prog >>= print -- print for testing purposes
  where
    prog = info
      (helper <*> configuration)
      ( fullDesc
     <> progDesc "Start a paste server"
     <> header "carte - a socket based paste server" )

Now we can test out this argument parser on the command line.

[nix-shell:~/misc/codereview/133747]$ ./carte -h
carte - a socket based paste server

Usage: carte [-p|--port PORT] [-u|--url URL] [-d|--dir DIRECTORY]
  Start a paste server

Available options:
  -h,--help                Show this help text
  -p,--port PORT           The PORT on which to listen for connections
  -u,--url URL             The root url for building links to files
  -d,--dir DIRECTORY       The DIRECTORY in which to store pastes

[nix-shell:~/misc/codereview/133747]$ ./carte --url="example.com" -d files
Configuration {port = 5001, url = "example.com", files = "files"}

State

I think you'll be happier with your state passing if you reexamine which functions need what data and where the responsibility lies for calculating certain values.

Consider your processing pipeline. The most essential single job it needs to perform is reading bytes out of a handle and putting those bytes to another handle.

-- | Writes data from first `Handle` to second `Handle` until EOF
-- is encountered. The `Handle`s are not closed.
pipe :: Handle -> Handle -> IO ()
pipe source sink = undefined -- Implementation left for later consideration

This is important because it captures essential functionality in the most direct manner possible. Functions like this are reusable components that can be built into larger solutions in easily comprehensible ways. E.g.,

receiveFile :: Handle -> FilePath -> IO ()
receiveFile source filepath = withBinaryFile filepath WriteMode (pipe source)

notify :: Handle -> URL -> IO ()
notify source url = undefined

newKey :: (Monad m) => StateT StdGen m String
newKey = -- Essentially unchanged from randId

handleUploader :: Handle -> StateT StdGen (ReaderT Configuration IO) ()
handleUploader source = do
    key <- newKey
    baseUrl <- asks url
    fileDir <- asks files
    void . liftIO $ do
      receiveFile source (fileDir </> key) -- Assumes (</>) ~= buildFileUrl
      notify source (baseUrl </> key)      -- Use whichever actual appropriate combinator
      hClose source

Security

You might receive an infinite stream of junk data, filling up your disk (if it doesn't first exhaust your memory due to mishandling of lazy IO).

Misbehaving clients might connect and then squat on the connection, not sending anything or closing the pipe, depriving your server of resources.

Depending on how you serve the files you receive, there's currently nothing to prevent you from re-serving e.g. a binary executable from a malicious uploader. You then become a file dump, and attract all sorts of nefarious users.

File hosting is tricky.


Other Libraries

For resource handling with strict upper bounds and more friendly interfaces, you might want to check out pipes, pipes-bytestring and network-simple.

For web frameworks, there's ample choice these days. I use servant in my daily work.


Miscellania

In loop, liftM opts get is just gets opts on StateTs.

In saveToDisk, intercalate "\n" is the same thing as unlines.

In currentTimeSeconds, use <$> which is an infix synonym for fmap. If you're using a recent version of GHC it should already be available in the Prelude. If not, import Data.Functor.

\$\endgroup\$
1
  • \$\begingroup\$ Woa. This answer was really helpful. I have learned a lot just by pushing the changes through. Thanks for the pointers. The network-simple library seems to offer some stuff to limit the upload size as well. Thanks for everything! :) \$\endgroup\$ Jul 5, 2016 at 13:03
1
\$\begingroup\$

If you used lens, randId would be zoom rnd $ base36 <$> StateT random

Using Control.Monad.Loops, eatData hdl [] is untilM (hGetLine handle) (hIsEOF handle), except that the list is the right way round.

Replacing loop s with forever $ loop s allows you to remove the last line, and thus the recursion, in loop's definition.

Prepending void $ to withSocketsDo allows you to remove the return ().

getStdGen skips getting system time.

Control.Monad.Random's MonadRandom allows you to require ability to generate random numbers in exactly the upwards call hierarchy of randId if you use mtl-style type signatures. You won't even need to specify that it is actually provided by IO (except in main), giving type level gurantees that you aren't using IO except for random numbers. Then you can wholly reduce Data to Opts.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.