Я всё-таки дописал этот функционал, хотя он отнял приличное количество времени. Попытаюсь поделиться своим опытом. Не буду рассказывать как реализовать получение списка файлов, т.к. в большей части это перекликается с самой загрузкой.

Oсторожно, сейчас будет простыня.

Во-первых, нам нужна форма загрузки:

<form class="well form-inline upload-form" action="/vault/fileupload" enctype="multipart/form-data" method="post">
  <strong>Загрузить: </strong>
  <input type="hidden" name="container" id="file-container" />
  <input type="file" name="file" id="file-upload"
    style="position: absolute; top: -100px; left: -100px;" />
  <button class="btn" type="button" id="file-button"> Выбрать </button>
  <input type="text" name="name" id="file-name" placeholder="Под именем" />
  <button class="btn" type="submit"> Отправить </button>
</form>

Мне захотелось кастомную кнопку выбора файлов, для этого оригинальную кнопку мы прячем, а клик по ней эмулируем:

$('#file-button').click(function () {
    $('#file-upload').click();
    return false;
});

Стоит обратить внимание на способ, которым кнопка спрятана. Если просто указать display: none, то опера перестанет воспринимать поддельные клики и окошко с выбором файла перестанет появляться. А если указать visibility: hidden, то старое поле будет занимать положенное ему место и получится дырка на форме.

Итак, форму нарисовали, можно писать обработчик:

vaultFileUpload :: AppHandler ()
vaultFileUpload = do
  tmpDir <- liftIO getTemporaryDirectory
  response <- handleFileUploads tmpDir uploadPolicy partUploadPolicy processForm
  writeBS $ pack $ encode response

Тут всё просто: получаем имя временной папки, обрабатываем форму и выводим результат, поэтому посмотрим внимательнее на функцию обработки:

response <- handleFileUploads tmpDir uploadPolicy partUploadPolicy processForm

Функция handleFileUploads принимает на вход 4 параметра: временная папка, глобальная политика загрузки, функция, возвращающая по описанию части локальную политику загрузки, и, наконец, функция для обработки полученных данных. Т.е. мы загружаем все или только некоторые файлы во временную папку и вызываем обработчик:

processForm ((_, Left uploadError) : []) = 
  return $ ServiceError $ show uploadError

processForm ((_, Right path) : []) = do
  container <- getPostParam "container"
  name <- getPostParam "name"
  if container == Nothing || name == Nothing
    then return $ ServiceError "Container or name not defined"
    else liftIO $ curlDo $ UploadFile path (unpack $ fromMaybe "" container) (unpack $ fromMaybe "" name)

processForm [] = return $ ServiceError "No files were transmitted"
processForm _ = return $ ServiceError "Too many files"

Интересен только второй случай, когда успешно загружен только один файл. Мы получаем два POST-параметра (имя контейнера Rackspace CloudFiles и имя, под которым файл должен быть загружен) и вызываем нашу функцию curlDo с описанием нужной операции. UploadFile — это конструктор моего типа ServiceAction, где просто перечислены все необходимые операции:

data ServiceAction
  = GetContainers
  | GetContainerItems String
  | UploadFile FilePath String String

Переходим к curlDo.

curlDo :: ServiceAction -> IO ServiceResponse
curlDo action = withCurlDo $ do
    h <- initialize
    response <- curl h "https://auth.api.rackspacecloud.com/v1.0"
      [CurlHttpHeaders 
        [ "X-Auth-Key: "  ++ rackspaceAuthKey
        , "X-Auth-User: " ++ rackspaceAuthUser
        ]
      ]
    
    let headers = M.map (dropWhile (== ' ')) $ M.fromList $ respHeaders response
    case respStatus response of
      204 -> processAction action 
        (headers M.! "X-Storage-Url") (headers M.! "X-CDN-Management-Url") 
        (headers M.! "X-Auth-Token")
      _ -> return $ ServiceError "Can't authenticate"

Мы отправляем аутентификационные данные на Cloud-сервер и проверяем их правильность. В случае удачи вызывается processAction с действием, которое нужно выполнить. Ну и кроме того передаются некоторые заголовки из ответа сервера — там указано, к каким серверам дальше обращаться.

В функции processAction несколько паттернов, по одному на каждую выполняемую операцию из типа ServiceAction. Вот тот, что используется для операции загрузки файла:

processAction (UploadFile filePath container name) url _ =
  uploadFile filePath container name url

Как видите, ничего особенного, просто вызов. Переходим к самому интересному — uploadFile. Каркас этой функции выглядит так:

uploadFile filePath container name url token = do
  h <- initialize
  response <- withBinaryFile filePath ReadMode processFile
  case respStatus response of
    201 -> return ServiceSuccess
    _ -> return $ ServiceDebug $ show $ respStatus response

Сначала мы инициализируем handle от curl c помощью initialize, затем оборачиваем в withBinaryFile работу с файлом (отправку) и отдаем результат в зависимости от кода, возвращенного сервером. Отправка файла реализуется через processFile:

processFile fh = do
  fileSize <- hFileSize fh
  curl h (url ++ "/" ++ container ++ "/" ++ name)
    [ CurlPut True
    , CurlHttpHeaders ["X-Auth-Token: " ++ token]
    , CurlReadFunction readFunction
    , CurlInFileSize $ fromInteger fileSize
    ]

Тут задаются опции для вызова curl. Самое интересное и сложное — это функция readFunction, которая отвечает за чтение файла и передачу данных в curl. Т.к. функция будет вызываться из libcurl, написана она весьма специфически с использованием библиотеки Foreign:

readFunction :: Ptr CChar -> CInt -> CInt -> Ptr () -> IO (Maybe CInt)
readFunction ptr size nmemb _ = do
  actualSize <- hGetBuf fh ptr $ fromInteger $ toInteger (size * nmemb)
  return $ if (actualSize > 0) then Just $ fromInteger $ toInteger actualSize else Nothing

hGetBuf читает из файла fh в область по указателю pts (size * nmemb) байт и возвращает количество действительно прочитанных байт. Ну и сама функция должна вернуть Maybe CInt, причем Nothing возвращается в случае, если ничего не прочитано и читать дальше не надо.

Если собрать весь код функции в одно место, получится как-то так:

uploadFile filePath container name url token = do
  h <- initialize
  let 
    processFile fh = do
      let 
        readFunction :: Ptr CChar -> CInt -> CInt -> Ptr () -> IO (Maybe CInt)
        readFunction ptr size nmemb _ = do
          actualSize <- hGetBuf fh ptr $ fromInteger $ toInteger (size * nmemb)
          return $ if (actualSize > 0) then Just $ fromInteger $ toInteger actualSize else Nothing

      fileSize <- hFileSize fh
      curl h (url ++ "/" ++ container ++ "/" ++ name)
        [ CurlPut True
        , CurlHttpHeaders ["X-Auth-Token: " ++ token]
        , CurlReadFunction readFunction
        , CurlInFileSize $ fromInteger fileSize
        ]

  response <- withBinaryFile filePath ReadMode processFile
  case respStatus response of
    201 -> return ServiceSuccess
    _ -> return $ ServiceDebug $ show $ respStatus response

Вот такими нехитрыми действиями можно пересылать файлы с клиента через промежуточный сервер на сервера Rackspace CloudFiles. Все исходники лежат на GitHub, где и подлежат и вдумчивому изучению (trollface).

Продолжаю попытки найти оптимальную IDE для программирования на Haskell. На повестке дня следующие кандидаты: IDEA Haskell или ideah, IDEA Custom File Type, Sublime Text 2, Leksah, EclipseFP.

К сожалению, ideah у меня так и не запустился. Постоянно показывал ошибку компиляции какого-то внутреннего модуля, а потому сразу выбывает из состязания. С EclipseFP я довольно много работал, и он практически всем хорош, кроме тормозов и отсутствия Zen Coding.

EclipseFP

Leksah выглядит необычно, но не буду к этому придираться. Никаких плюшек относительно языков, отличных от Haskell, а ведь в проекте используются еще и стандартные web-технологии: HTML, JavaScript и CSS. Компилирует и ищет ошибки при нажатии соответствующий клавиши. Ctrl+клик мышкой открывает в боковой панели определение функции (не работает для локальных функций, и вдобавок я так и не нашел, как это сделать только с клавиатуры). Автодополнение показывает в списке типы функций. И даже есть дебаггер!

Leksah

IDEA Custom File Type подразумевает, что будет определен синтаксис с помощью специальной встроенной в идею фичи, которая позволяет минимально определить синтаксис языка (комментарии, числа, зарезервированные слова). Естественно этот способ имеет свои ограничения. Например, в идентификаторе с одинарной кавычкой на конце эта кавычка будет считаться началом строки, а не концом идентификатора, и соответственно всё будет подсвечено неверно. Компилировать проект можно, определив External Tool и повесив на него горячую клавишу. Конечно придется самому продираться через вывод компилятора и искать места ошибок. Ни о каких подсказках с типами, как и о адекватной навигации мечтать не приходится. Это всё были минусы. А теперь к плюсам, он один, но зато огромный: офигенная поддержка всех остальных языков, используемых в проекте. Тут и Zen Coding, и дополнение используемых классов в jQuery селекторах, и рефакторинг в JavaScript и CSS.

IDEA Custom File Type

Переходим к Sublime Text 2. Я слышал очень много хороших отзывов об этом редакторе и решил попробовать. Выглядит он очень хорошо, сразу видно, что разработчики потратили кучу времени на оттачивание пользовательского интерфейса. Ставим пакет поддержки Haskell. В итоге получаем компиляцию проекта при сохранении, подсветку ошибок в коде. Нет подсказок с типами, автодополнение показывает просто набор слов из текущего проекта. Пакет с Zen Coding есть. В общем хороший, годный редактор.

Sublime Text 2

Как видно, у каждого редактора есть свои плюсы и минусы. Думаю, что самое большое счастье было бы, если бы удалось запустить ideah, потому что Custom File Type для работы явно недостаточно. Надо будет потратить еще некоторое время на допиливание этого плагина, вдруг что-нибудь да получится. А пока я останусь на Sublime Text.

UPD: продолжение истории.

Когда-то давным-давно, еще в универе, я очень любил Eclipse. Бесплатный, постоянно развивающийся, с кучей всяческих плюшек для разработки. Eclipse PDT был верхом удобства для написания кода. Да и когда речь заходила о Java, я совсем не понимал, что такого есть в Идее, чего нет в Эклипсе.

Прошло время, Jetbrains выпустили PhpStorm. И он настолько превосходил PDT и Zend Studio по производительности и удобству, что стал практически неотъемлемой частью рабочего процесса.

Теперь, когда я пишу на Haskell, снова приходится воевать с Eclipse, потому что он всё больше меня раздражает своими тормозами. Но более адекватного редактора я пока не нашел.

Обнаружил, что нативная реализация http-протокола для Haskell (Network.HTTP) не поддерживает https. Придется, видимо, использовать совсем не функциональные биндинги для libcurl (Network.Curl).

Здравствуйте. Сегодня я расскажу вам про Haskell и про то, что получается на стыке его ленивости и императивности всех окружающих программ.

Как вы, наверное, уже знаете, я написал этот сайт на Haskell с использованием Snap Framework. Так вот, для хранения данных у меня используется MySQL, а для работы с этими данными — целая куча библиотек: HDBC, HDBC-mysql, snaplet-hdbc. И где-то во всем этом зоопарке при выполнении запроса к базе возникала ошибка:

SqlError {seState = "", seNativeError = 2050, seErrorMsg = "Row retrieval was canceled by mysql_stmt_close() call"}

Гугл ничего не знал об этом, я тоже, поэтому ошибку отложил до лучших времен, благо возникала она нечасто и лечилась перезагрузкой страницы. И вот на глаза мне попалась такая страница на Stack Overflow. Я полез смотреть код Snap.Snaplet.Hdbc:

-- | Execute a @SELECT@ query on the database by passing the query as 'String',
-- together with a list of values to bind to it. A list of 'Row's is returned.
query
  :: HasHdbc m c s
  => String -- ^ The raw SQL to execute. Use @?@ to indicate placeholders.
  -> [SqlValue] -- ^ Values for each placeholder according to its position in
                 -- the SQL statement.
  -> m [Row] -- ^ A 'Map' of attribute name to attribute value for each
                 -- row. Can be the empty list.
query sql bind = do
  stmt <- prepare sql
  liftIO $ HDBC.execute stmt bind
  liftIO $ HDBC.fetchAllRowsMap' stmt

Вроде всё хорошо. Единственное: может, попробовать закрыть statement принудительно? Что я и сделал. Не поверите, помогло. По крайней мере ошибок я больше не увидел. Две переписанных мною функции:

query :: HasHdbc m c s => String -> [SqlValue] -> m [Row]
query sql bind = do
  stmt <- prepare sql
  liftIO $ HDBC.execute stmt bind
  rows <- liftIO $ HDBC.fetchAllRowsMap' stmt
  liftIO $ HDBC.finish stmt
  return rows
  
query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer
query' sql bind = withHdbc $ \conn -> do
  stmt <- HDBC.prepare conn sql
  count <- liftIO $ HDBC.execute stmt bind
  liftIO $ HDBC.finish stmt
  liftIO $ HDBC.commit conn
  return count

Если вы вдруг снова увидите эту ошибку, вы же мне сообщите?